X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=be6cc69917f250174f30cd7f0ce68ddd3c7c691b;hb=4255b37e50876702d2563f3418a44a3f5bf8a2e8;hp=2013e120ce19889803b845e8ab900874db66ef7e;hpb=621eebe206ae6c6d0d0897d43247ce5e05c2359a;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 2013e12..be6cc69 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -294,7 +294,24 @@ (multiple-value-bind (existsp errno ino mode nlink uid gid rdev size atime mtime) (sb!unix:unix-stat filename) - (declare (ignore ino nlink gid rdev size atime)) + (declare (ignore ino nlink gid rdev size atime + #!+win32 uid)) + #!+win32 + ;; On win32, stat regards UNC pathnames and device names as + ;; nonexisting, so we check once more with the native API. + (unless existsp + (setf existsp + (let ((handle (sb!win32:create-file + filename 0 0 nil + sb!win32:file-open-existing + 0 0))) + (when (/= -1 handle) + (setf mode + (or mode + (if (logbitp 4 + (sb!win32:get-file-attributes filename)) + sb!unix:s-ifdir 0))) + (progn (sb!win32:close-handle handle) t))))) (if existsp (case query-for (:existence (nth-value @@ -322,7 +339,9 @@ ;; ... but without any trailing slash. :as-directory (eql (logand mode sb!unix:s-ifmt) sb!unix:s-ifdir)))) - (:author (sb!unix:uid-username uid)) + (:author + #!-win32 + (sb!unix:uid-username uid)) (:write-date (+ unix-to-universal-time mtime))) (progn ;; SBCL has for many years had a policy that a pathname @@ -447,7 +466,8 @@ or if PATHSPEC is a wild pathname." (let* ((original (truename file)) (original-namestring (native-namestring original :as-file t)) (new-name (merge-pathnames new-name original)) - (new-namestring (native-namestring new-name :as-file t))) + (new-namestring (native-namestring (physicalize-pathname new-name) + :as-file t))) (unless new-namestring (error 'simple-file-error :pathname new-name @@ -467,21 +487,64 @@ or if PATHSPEC is a wild pathname." (defun delete-file (file) #!+sb-doc - "Delete the specified FILE." - (let* ((truename (probe-file file)) - (namestring (when truename - (native-namestring truename :as-file t)))) + "Delete the specified FILE. + +If FILE is a stream, on Windows the stream is closed immediately. On Unix +plaforms the stream remains open, allowing IO to continue: the OS resources +associated with the deleted file remain available till the stream is closed as +per standard Unix unlink() behaviour." + (let* ((pathname (translate-logical-pathname + (merge-pathnames file (sane-default-pathname-defaults)))) + (namestring (native-namestring pathname :as-file t))) + #!+win32 (when (streamp file) - (close file :abort t)) - (unless namestring - (error 'simple-file-error - :pathname file - :format-control "~S doesn't exist." - :format-arguments (list file))) + (close file)) (multiple-value-bind (res err) (sb!unix:unix-unlink namestring) (unless res (simple-file-perror "couldn't delete ~A" namestring err)))) t) + +(defun delete-directory (pathspec &key recursive) + "Deletes the directory designated by PATHSPEC (a pathname designator). +Returns the truename of the directory deleted. + +If RECURSIVE is false \(the default), signals an error unless the directory is +empty. If RECURSIVE is true, first deletes all files and subdirectories. If +RECURSIVE is true and the directory contains symbolic links, the links are +deleted, not the files and directories they point to. + +Signals an error if PATHSPEC designates a file instead of a directory, or if +the directory could not be deleted for any reason. + +\(DELETE-DIRECTORY \"/tmp/foo\") and \(DELETE-DIRECTORY \"/tmp/foo/\") both +delete the \"foo\" subdirectory of \"/tmp\", or signal an error if it does not +exist or is a file." + (declare (type pathname-designator pathspec)) + (with-pathname (pathname pathspec) + (let ((truename (truename (translate-logical-pathname pathname)))) + (labels ((recurse (dir) + (map-directory #'recurse dir + :files nil + :directories t + :classify-symlinks nil) + (map-directory #'delete-file dir + :files t + :directories nil + :classify-symlinks nil) + (delete-dir dir)) + (delete-dir (dir) + (let* ((namestring (native-namestring dir :as-file t)) + (res (alien-funcall (extern-alien #!-win32 "rmdir" + #!+win32 "_rmdir" + (function int c-string)) + namestring))) + (if (minusp res) + (simple-file-perror "Could not delete directory ~A:~% ~A" + namestring (get-errno)) + dir)))) + (if recursive + (recurse truename) + (delete-dir truename)))))) (defun sbcl-homedir-pathname () (let ((sbcl-home (posix-getenv "SBCL_HOME"))) @@ -493,30 +556,32 @@ or if PATHSPEC is a wild pathname." *default-pathname-defaults* :as-directory t)))) +(defun user-homedir-namestring (&optional username) + (if username + (sb!unix:user-homedir username) + (let ((env-home (posix-getenv "HOME"))) + (if (and env-home (not (string= env-home ""))) + env-home + #!-win32 + (sb!unix:uid-homedir (sb!unix:unix-getuid)))))) + ;;; (This is an ANSI Common Lisp function.) (defun user-homedir-pathname (&optional host) #!+sb-doc "Return the home directory of the user as a pathname. If the HOME environment variable has been specified, the directory it designates is returned; otherwise obtains the home directory from the operating -system." +system. HOST argument is ignored by SBCL." (declare (ignore host)) - (let ((env-home (posix-getenv "HOME"))) - (values - (parse-native-namestring - (if (and env-home (not (string= env-home ""))) - env-home - #!-win32 - (sb!unix:uid-homedir (sb!unix:unix-getuid)) - #!+win32 - ;; Needs to bypass PARSE-NATIVE-NAMESTRING & ENSURE-TRAILING-SLASH - ;; What?! -- RMK, 2007-12-31 - (return-from user-homedir-pathname - (sb!win32::get-folder-pathname sb!win32::csidl_profile))) - #!-win32 sb!impl::*unix-host* - #!+win32 sb!impl::*win32-host* - *default-pathname-defaults* - :as-directory t)))) + (values + (parse-native-namestring + (or (user-homedir-namestring) + #!+win32 + (sb!win32::get-folder-namestring sb!win32::csidl_profile)) + #!-win32 sb!impl::*unix-host* + #!+win32 sb!impl::*win32-host* + *default-pathname-defaults* + :as-directory t))) ;;;; DIRECTORY @@ -550,31 +615,21 @@ matching filenames." truename)))) (do-physical-pathnames (pathname) (aver (not (logical-pathname-p pathname))) - (let* ((name (pathname-name pathname)) + (let* (;; KLUDGE: Since we don't canonize pathnames on construction, + ;; we really have to do it here to get #p"foo/." mean the same + ;; as #p"foo/./". + (pathname (canonicalize-pathname pathname)) + (name (pathname-name pathname)) (type (pathname-type pathname)) - ;; KLUDGE: We want #p"/foo" to match #p"/foo/, - ;; so cobble up a directory name component from - ;; name and type -- just take care with "*.*"! - (dirname (if (and (eq :wild name) (eq :wild type)) - "*" - (with-output-to-string (s) - (when name - (write-string (unparse-physical-piece name) s)) - (when type - (write-string "." s) - (write-string (unparse-physical-piece type) s))))) - (dir (maybe-make-pattern dirname 0 (length dirname))) (match-name (make-matcher name)) - (match-type (make-matcher type)) - (match-dir (make-matcher dir))) + (match-type (make-matcher type))) (map-matching-directories (if (or name type) (lambda (directory) - (map-matching-files #'record - directory - match-name - match-type - match-dir)) + (map-matching-entries #'record + directory + match-name + match-type)) #'record) pathname))) (do-pathnames (pathname) @@ -599,6 +654,46 @@ matching filenames." #'string< :key #'car)))) +(defun canonicalize-pathname (pathname) + ;; We're really only interested in :UNSPECIFIC -> NIL, :BACK and :UP, + ;; and dealing with #p"foo/.." and #p"foo/." + (labels ((simplify (piece) + (unless (eq :unspecific piece) + piece)) + (canonicalize-directory (directory) + (let (pieces) + (dolist (piece directory) + (if (and pieces (member piece '(:back :up))) + ;; FIXME: We should really canonicalize when we construct + ;; pathnames. This is just wrong. + (case (car pieces) + ((:absolute :wild-inferiors) + (error 'simple-file-error + :format-control "Invalid use of ~S after ~S." + :format-arguments (list piece (car pieces)) + :pathname pathname)) + ((:relative :up :back) + (push piece pieces)) + (t + (pop pieces))) + (push piece pieces))) + (nreverse pieces)))) + (let ((name (simplify (pathname-name pathname))) + (type (simplify (pathname-type pathname))) + (dir (canonicalize-directory (pathname-directory pathname)))) + (cond ((equal "." name) + (cond ((not type) + (make-pathname :name nil :defaults pathname)) + ((equal "" type) + (make-pathname :name nil + :type nil + :directory (butlast dir) + :defaults pathname)))) + (t + (make-pathname :name name :type type + :directory dir + :defaults pathname)))))) + ;;; Given a native namestring, provides a WITH-HASH-TABLE-ITERATOR style ;;; interface to mapping over namestrings of entries in the corresponding ;;; directory. @@ -641,55 +736,84 @@ matching filenames." ;;; This is our core directory access interface that we use to implement ;;; DIRECTORY. -(defun map-directory (function directory &key (files t) (directories t) (errorp t)) +(defun map-directory (function directory &key (files t) (directories t) + (classify-symlinks t) (errorp t)) #!+sb-doc - "Call FUNCTION with the pathname for each entry in DIRECTORY as follows: if -FILES is true (the default), FUNCTION is called for each file in the -directory; if DIRECTORIES is true (the default), FUNCTION is called for each -subdirectory. If ERRORP is true (the default) signal an error if DIRECTORY -does not exist, cannot be read, etc. + "Map over entries in DIRECTORY. Keyword arguments specify which entries to +map over, and how: + + :FILES + If true, call FUNCTION with the pathname of each file in DIRECTORY. + Defaults to T. -On platforms supporting symbolic links the decision to call FUNCTION with its -pathname depends on the resolution of the link: if it points to a directory, -it is considered a directory entry. Whether it is considered a file or a -directory, the provided pathname is not fully resolved, but rather names the -symbolic link as an immediate child of DIRECTORY. + :DIRECTORIES + If true, call FUNCTION with a pathname for each subdirectory of DIRECTORY. + If :AS-FILES, the pathname used is a pathname designating the subdirectory + as a file in DIRECTORY. Otherwise the pathname used is a directory + pathname. Defaults to T. + + :CLASSIFY-SYMLINKS + If true, the decision to call FUNCTION with the pathname of a symbolic link + depends on the resolution of the link: if it points to a directory, it is + considered a directory entry, otherwise a file entry. If false, all + symbolic links are considered file entries. In both cases the pathname used + for the symbolic link is not fully resolved, but names it as an immediate + child of DIRECTORY. Defaults to T. + + :ERRORP + If true, signal an error if DIRECTORY does not exist, cannot be read, etc. + Defaults to T. Experimental: interface subject to change." + (declare (pathname-designator directory)) (let* ((fun (%coerce-callable-to-fun function)) - (realname (or (query-file-system directory :existence errorp) - (return-from map-directory nil))) - (host (pathname-host realname)) - ;; We want the trailing separator: better to ask the - ;; provide it rather than reason about its presence here. - (dirname (native-namestring realname :as-file nil))) - (with-native-directory-iterator (next dirname :errorp errorp) - (loop for name = (next) - while name - do (let* ((full (concatenate 'string dirname name)) - (kind (native-file-kind full))) - (when kind - (case kind - (:directory - (when directories - (funcall fun (parse-native-namestring - full host realname :as-directory t)))) - (:symlink - (let* ((tmpname (parse-native-namestring - full host realname :as-directory nil)) - (truename (query-file-system tmpname :truename nil))) - (if (or (not truename) - (or (pathname-name truename) (pathname-type truename))) - (when files - (funcall fun tmpname)) - (when directories - (funcall fun (parse-native-namestring - full host realname :as-directory t)))))) - (t - ;; Anything else parses as a file. - (when files - (funcall fun (parse-native-namestring - full host realname :as-directory nil))))))))))) + (as-files (eq :as-files directories)) + (physical (physicalize-pathname directory)) + ;; Not QUERY-FILE-SYSTEM :EXISTENCE, since it doesn't work on Windows + ;; network shares. + (realname (sb!unix:unix-realpath (native-namestring physical :as-file t))) + (canonical (if realname + (parse-native-namestring realname + (pathname-host physical) + (sane-default-pathname-defaults) + :as-directory t) + (return-from map-directory nil))) + (dirname (native-namestring canonical))) + (flet ((map-it (name dirp) + (funcall fun + (merge-pathnames (parse-native-namestring + name nil physical + :as-directory (and dirp (not as-files))) + physical)))) + (with-native-directory-iterator (next dirname :errorp errorp) + (loop for name = (next) + while name + do (let* ((full (concatenate 'string dirname name)) + (kind (native-file-kind full))) + (when kind + (case kind + (:directory + (when directories + (map-it name t))) + (:symlink + (if classify-symlinks + (let* ((tmpname (merge-pathnames + (parse-native-namestring + name nil physical :as-directory nil) + physical)) + (truename (query-file-system tmpname :truename nil))) + (if (or (not truename) + (or (pathname-name truename) (pathname-type truename))) + (when files + (funcall fun tmpname)) + (when directories + (map-it name t)))) + (when files + (map-it name nil)))) + (t + ;; Anything else parses as a file. + (when files + (map-it name nil))))))))))) ;;; Part of DIRECTORY: implements matching the directory spec. Calls FUNCTION ;;; with all DIRECTORIES that match the directory portion of PATHSPEC. @@ -717,7 +841,8 @@ Experimental: interface subject to change." (map-wild function rest starting-point)) (t ;; Nothing wild -- the directory matches itself. - (funcall function starting-point))))) + (funcall function starting-point)))) + nil) (defun last-directory-piece (pathname) (car (last (pathname-directory pathname)))) @@ -732,25 +857,21 @@ Experimental: interface subject to change." ;; end of the line (funcall function subdirectory)) ((or (eq :wild next) (typep next 'pattern)) - (lambda (pathname) - (map-wild function more pathname))) + (map-wild function more subdirectory)) ((eq :wild-inferiors next) - (lambda (pathname) - (map-wild-inferiors function more pathname))) + (map-wild-inferiors function more subdirectory)) (t - (lambda (pathname) - (let ((this (pathname-directory pathname))) - (when (equal next (car (last this))) - (map-matching-directories - function - (make-pathname :directory (append this more) - :defaults pathname))))))))) + (let ((this (pathname-directory subdirectory))) + (map-matching-directories + function + (make-pathname :directory (append this more) + :defaults subdirectory))))))) (map-directory (if (eq :wild this) #'cont (lambda (sub) - (awhen (pattern-matches this (last-directory-piece sub)) - (funcall #'cont it)))) + (when (pattern-matches this (last-directory-piece sub)) + (funcall #'cont sub)))) directory :files nil :directories t @@ -784,20 +905,17 @@ Experimental: interface subject to change." :directories t :errorp nil))) -;;; Part of DIRECTORY: implements iterating over files in a directory, and matching -;;; them. -(defun map-matching-files (function directory match-name match-type match-dir) +;;; Part of DIRECTORY: implements iterating over entries in a directory, and +;;; matching them. +(defun map-matching-entries (function directory match-name match-type) (map-directory (lambda (file) - (let ((pname (pathname-name file)) - (ptype (pathname-type file))) - (when (if (or pname ptype) - (and (funcall match-name pname) (funcall match-type ptype)) - (funcall match-dir (last-directory-piece file))) - (funcall function file)))) + (when (and (funcall match-name (pathname-name file)) + (funcall match-type (pathname-type file))) + (funcall function file))) directory :files t - :directories t + :directories :as-files :errorp nil)) ;;; NOTE: There is a fair amount of hair below that is probably not @@ -887,7 +1005,7 @@ Experimental: interface subject to change." ((or (null one) (eq one :unspecific)) two) ((or (null two) (eq two :unspecific)) one) ((string= one two) one) - (t nil))) + (t (return-from pathname-intersections nil)))) (intersect-directory (one two) (aver (typep one '(or null (member :wild :unspecific) list))) (aver (typep two '(or null (member :wild :unspecific) list)))