X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=b51c6014e5ce9f48f0f0db989472da93cbf87830;hb=a7699535aaba71765335f3be0a2103b2f07941af;hp=0cac4e79274998fc26d63b05f0e63e288bd0c9b7;hpb=8b244d668721358d4a452650a9e608149c72c8f2;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 0cac4e7..b51c601 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -291,111 +291,120 @@ (simple-file-perror note-format pathname errno) (return-from query-file-system nil)))) (let ((filename (native-namestring pathname :as-file t))) + #!+win32 + (case query-for + ((:existence :truename) + (multiple-value-bind (file kind) + (sb!win32::native-probe-file-name filename) + (when (and (not file) kind) + (setf file filename)) + ;; The following OR was an AND, but that breaks files like NUL, + ;; for which GetLongPathName succeeds yet GetFileAttributesEx + ;; fails to return the file kind. --DFL + (if (or file kind) + (values + (parse-native-namestring + file + (pathname-host pathname) + (sane-default-pathname-defaults) + :as-directory (eq :directory kind))) + (fail "couldn't resolve ~A" filename + (- (sb!win32:get-last-error)))))) + (:write-date + (or (sb!win32::native-file-write-date filename) + (fail "couldn't query write date of ~A" filename + (- (sb!win32:get-last-error)))))) + #!-win32 (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 - #!+win32 uid)) - (if existsp - (case query-for - (:existence (nth-value - 0 - (parse-native-namestring - filename - (pathname-host pathname) - (sane-default-pathname-defaults) - :as-directory (eql (logand mode sb!unix:s-ifmt) - sb!unix:s-ifdir)))) - (:truename (nth-value - 0 - (parse-native-namestring - ;; Note: in case the file is stat'able, POSIX - ;; realpath(3) gets us a canonical absolute - ;; filename, even if the post-merge PATHNAME - ;; is not absolute... - (multiple-value-bind (realpath errno) - (sb!unix:unix-realpath filename) - (if realpath - realpath - (fail "couldn't resolve ~A" filename errno))) - (pathname-host pathname) - (sane-default-pathname-defaults) - ;; ... but without any trailing slash. - :as-directory (eql (logand mode sb!unix:s-ifmt) - sb!unix:s-ifdir)))) - (: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 - ;; that names an existing, dangling or self-referential - ;; symlink denotes the symlink itself. stat(2) fails - ;; and sets errno to ENOENT or ELOOP respectively, but - ;; we must distinguish cases where the symlink exists - ;; from ones where there's a loop in the apparent - ;; containing directory. - #!-win32 - (multiple-value-bind (linkp ignore ino mode nlink uid gid rdev - size atime mtime) - (sb!unix:unix-lstat filename) - (declare (ignore ignore ino mode nlink gid rdev size atime)) - (when (and (or (= errno sb!unix:enoent) - (= errno sb!unix:eloop)) - linkp) - (return-from query-file-system - (case query-for - (:existence - ;; We do this reparse so as to return a - ;; normalized pathname. - (parse-native-namestring - filename (pathname-host pathname))) - (:truename - ;; So here's a trick: since lstat succeded, - ;; FILENAME exists, so its directory exists and - ;; only the non-directory part is loopy. So - ;; let's resolve FILENAME's directory part with - ;; realpath(3), in order to get a canonical - ;; absolute name for the directory, and then - ;; return a pathname having PATHNAME's name, - ;; type, and version, but the rest from the - ;; truename of the directory. Since we turned - ;; PATHNAME into FILENAME "as a file", FILENAME - ;; does not end in a slash, and so we get the - ;; directory part of FILENAME by reparsing - ;; FILENAME and masking off its name, type, and - ;; version bits. But note not to call ourselves - ;; recursively, because we don't want to - ;; re-merge against *DEFAULT-PATHNAME-DEFAULTS*, - ;; since PATHNAME may be a relative pathname. - (merge-pathnames - (nth-value - 0 - (parse-native-namestring - (multiple-value-bind (realpath errno) - (sb!unix:unix-realpath - (native-namestring - (make-pathname - :name :unspecific - :type :unspecific - :version :unspecific - :defaults (parse-native-namestring - filename - (pathname-host pathname) - (sane-default-pathname-defaults))))) - (if realpath - realpath - (fail "couldn't resolve ~A" filename errno))) - (pathname-host pathname) - (sane-default-pathname-defaults) - :as-directory t)) - pathname)) - (:author (sb!unix:uid-username uid)) - (:write-date (+ unix-to-universal-time mtime)))))) - ;; If we're still here, the file doesn't exist; error. - (fail - (format nil "failed to find the ~A of ~~A" query-for) - pathspec errno)))))))) + (declare (ignore ino nlink gid rdev size atime)) + (labels ((parse (filename &key (as-directory + (eql (logand mode + sb!unix:s-ifmt) + sb!unix:s-ifdir))) + (values + (parse-native-namestring + filename + (pathname-host pathname) + (sane-default-pathname-defaults) + :as-directory as-directory))) + (resolve-problematic-symlink (&optional realpath-failed) + ;; SBCL has for many years had a policy that a pathname + ;; that names an existing, dangling or self-referential + ;; symlink denotes the symlink itself. stat(2) fails + ;; and sets errno to ENOENT or ELOOP respectively, but + ;; we must distinguish cases where the symlink exists + ;; from ones where there's a loop in the apparent + ;; containing directory. + ;; Also handles symlinks in /proc/pid/fd/ to + ;; pipes or sockets on Linux + (multiple-value-bind (linkp ignore ino mode nlink uid gid rdev + size atime mtime) + (sb!unix:unix-lstat filename) + (declare (ignore ignore ino mode nlink gid rdev size atime)) + (when (and (or (= errno sb!unix:enoent) + (= errno sb!unix:eloop) + realpath-failed) + linkp) + (return-from query-file-system + (case query-for + (:existence + ;; We do this reparse so as to return a + ;; normalized pathname. + (parse filename :as-directory nil)) + (:truename + ;; So here's a trick: since lstat succeded, + ;; FILENAME exists, so its directory exists and + ;; only the non-directory part is loopy. So + ;; let's resolve FILENAME's directory part with + ;; realpath(3), in order to get a canonical + ;; absolute name for the directory, and then + ;; return a pathname having PATHNAME's name, + ;; type, and version, but the rest from the + ;; truename of the directory. Since we turned + ;; PATHNAME into FILENAME "as a file", FILENAME + ;; does not end in a slash, and so we get the + ;; directory part of FILENAME by reparsing + ;; FILENAME and masking off its name, type, and + ;; version bits. But note not to call ourselves + ;; recursively, because we don't want to + ;; re-merge against *DEFAULT-PATHNAME-DEFAULTS*, + ;; since PATHNAME may be a relative pathname. + (merge-pathnames + (parse + (multiple-value-bind (realpath errno) + (sb!unix:unix-realpath + (native-namestring + (make-pathname + :name :unspecific + :type :unspecific + :version :unspecific + :defaults (parse filename + :as-directory nil)))) + (or realpath + (fail "couldn't resolve ~A" filename errno))) + :as-directory t) + pathname)) + (:author (sb!unix:uid-username uid)) + (:write-date (+ unix-to-universal-time mtime)))))) + ;; If we're still here, the file doesn't exist; error. + (fail + (format nil "failed to find the ~A of ~~A" query-for) + pathspec errno))) + (if existsp + (case query-for + (:existence (parse filename)) + (:truename + ;; Note: in case the file is stat'able, POSIX + ;; realpath(3) gets us a canonical absolute + ;; filename, even if the post-merge PATHNAME + ;; is not absolute + (parse (or (sb!unix:unix-realpath filename) + (resolve-problematic-symlink t)))) + (:author (sb!unix:uid-username uid)) + (:write-date (+ unix-to-universal-time mtime))) + (resolve-problematic-symlink)))))))) (defun probe-file (pathspec) @@ -446,9 +455,11 @@ or if PATHSPEC is a wild pathname." (defun rename-file (file new-name) #!+sb-doc "Rename FILE to have the specified NEW-NAME. If FILE is a stream open to a - file, then the associated file is renamed." - (let* ((original (truename file)) - (original-namestring (native-namestring original :as-file t)) +file, then the associated file is renamed." + (let* ((original (merge-pathnames file (sane-default-pathname-defaults))) + (old-truename (truename original)) + (original-namestring (native-namestring (physicalize-pathname original) + :as-file t)) (new-name (merge-pathnames new-name original)) (new-namestring (native-namestring (physicalize-pathname new-name) :as-file t))) @@ -467,7 +478,7 @@ or if PATHSPEC is a wild pathname." :format-arguments (list original new-name (strerror error)))) (when (streamp file) (file-name file new-name)) - (values new-name original (truename new-name))))) + (values new-name old-truename (truename new-name))))) (defun delete-file (file) #!+sb-doc @@ -477,15 +488,91 @@ 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* ((truename (truename file)) - (namestring (native-namestring truename :as-file t))) + (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)) - (multiple-value-bind (res err) (sb!unix:unix-unlink namestring) - (unless res - (simple-file-perror "couldn't delete ~A" namestring err)))) + (multiple-value-bind (res err) + #!-win32 (sb!unix:unix-unlink namestring) + #!+win32 (or (sb!win32::native-delete-file namestring) + (values nil (- (sb!win32:get-last-error)))) + (unless res + (simple-file-perror "couldn't delete ~A" namestring err)))) t) + +(defun directorize-pathname (pathname) + (if (or (pathname-name pathname) + (pathname-type pathname)) + (make-pathname :directory (append (pathname-directory pathname) + (list (file-namestring pathname))) + :host (pathname-host pathname) + :device (pathname-device pathname)) + pathname)) + +(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 or a symbolic link instead of a +directory, or if the directory could not be deleted for any reason. + +Both + + \(DELETE-DIRECTORY \"/tmp/foo\") + \(DELETE-DIRECTORY \"/tmp/foo/\") + +delete the \"foo\" subdirectory of \"/tmp\", or signal an error if it does not +exist or if is a file or a symbolic link." + (declare (type pathname-designator pathspec)) + (let ((physical (directorize-pathname + (physicalize-pathname + (merge-pathnames + pathspec (sane-default-pathname-defaults)))))) + (labels ((recurse-merged (dir) + (lambda (sub) + (recurse (merge-pathnames sub dir)))) + (delete-merged (dir) + (lambda (file) + (delete-file (merge-pathnames file dir)))) + (recurse (dir) + (map-directory (recurse-merged dir) dir + :files nil + :directories t + :classify-symlinks nil) + (map-directory (delete-merged dir) dir + :files t + :directories nil + :classify-symlinks nil) + (delete-dir dir)) + (delete-dir (dir) + (let ((namestring (native-namestring dir :as-file t))) + (multiple-value-bind (res errno) + #!+win32 + (or (sb!win32::native-delete-directory namestring) + (values nil (- (sb!win32:get-last-error)))) + #!-win32 + (values + (not (minusp (alien-funcall + (extern-alien "rmdir" + (function int c-string)) + namestring))) + (get-errno)) + (if res + dir + (simple-file-perror + "Could not delete directory ~A" + namestring errno)))))) + (if recursive + (recurse physical) + (delete-dir physical))))) + (defun sbcl-homedir-pathname () (let ((sbcl-home (posix-getenv "SBCL_HOME"))) @@ -497,30 +584,32 @@ per standard Unix unlink() behaviour." *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 @@ -602,7 +691,8 @@ matching filenames." (canonicalize-directory (directory) (let (pieces) (dolist (piece directory) - (if (and pieces (member piece '(:back :up))) + (cond + ((and pieces (member piece '(:back :up))) ;; FIXME: We should really canonicalize when we construct ;; pathnames. This is just wrong. (case (car pieces) @@ -614,8 +704,17 @@ matching filenames." ((:relative :up :back) (push piece pieces)) (t - (pop pieces))) - (push piece pieces))) + (pop pieces)))) + ((equal piece ".") + ;; This case only really matters on Windows, + ;; because on POSIX, our call site (TRUENAME via + ;; QUERY-FILE-SYSTEM) only passes in pathnames from + ;; realpath(3), in which /./ has been removed + ;; already. Windows, however, depends on us to + ;; perform this fixup. -- DFL + ) + (t + (push piece pieces)))) (nreverse pieces)))) (let ((name (simplify (pathname-name pathname))) (type (simplify (pathname-type pathname))) @@ -644,6 +743,10 @@ matching filenames." (macrolet ((,iterator () `(funcall ,',one-iter))) ,@body))) + #!+win32 + (sb!win32::native-call-with-directory-iterator + #'iterate ,namestring ,errorp) + #!-win32 (call-with-native-directory-iterator #'iterate ,namestring ,errorp)))) (defun call-with-native-directory-iterator (function namestring errorp) @@ -675,7 +778,8 @@ 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 "Map over entries in DIRECTORY. Keyword arguments specify which entries to map over, and how: @@ -690,24 +794,24 @@ map over, and how: 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. -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. - Experimental: interface subject to change." (declare (pathname-designator directory)) (let* ((fun (%coerce-callable-to-fun function)) (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))) + (realname (query-file-system physical :existence nil)) (canonical (if realname (parse-native-namestring realname (pathname-host physical) @@ -722,31 +826,39 @@ Experimental: interface subject to change." :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 - (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))))) - (t - ;; Anything else parses as a file. - (when files - (map-it name nil))))))))))) + (loop + ;; provision for FindFirstFileExW-based iterator that should be used + ;; on Windows: file kind is known instantly there, so we'll have it + ;; returned by (next) soon. + (multiple-value-bind (name kind) (next) + (unless (or name kind) (return)) + (unless kind + (setf kind (native-file-kind + (concatenate 'string dirname name)))) + (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. @@ -938,7 +1050,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))) @@ -1028,6 +1140,12 @@ Experimental: interface subject to change." (car one) (car two)) x)) (intersect-directory-helper (cdr one) (cdr two))))))))) + +(defun directory-pathname-p (pathname) + (and (pathnamep pathname) + (null (pathname-name pathname)) + (null (pathname-type pathname)))) + (defun ensure-directories-exist (pathspec &key verbose (mode #o777)) #!+sb-doc "Test whether the directories containing the specified file @@ -1040,37 +1158,48 @@ Experimental: interface subject to change." (error 'simple-file-error :format-control "bad place for a wild pathname" :pathname pathspec)) - (let ((dir (pathname-directory pathname))) - (loop for i from 1 upto (length dir) - do (let ((newpath (make-pathname - :host (pathname-host pathname) - :device (pathname-device pathname) - :directory (subseq dir 0 i)))) - (unless (probe-file newpath) - (let ((namestring (coerce (native-namestring newpath) - 'string))) - (when verbose - (format *standard-output* - "~&creating directory: ~A~%" - namestring)) - (sb!unix:unix-mkdir namestring mode) - (unless (probe-file newpath) - (restart-case (error - 'simple-file-error - :pathname pathspec - :format-control - "can't create directory ~A" - :format-arguments (list namestring)) - (retry () - :report "Retry directory creation." - (ensure-directories-exist - pathspec - :verbose verbose :mode mode)) - (continue () - :report - "Continue as if directory creation was successful." - nil))) - (setf created-p t))))) + (let* ((dir (pathname-directory pathname)) + (*default-pathname-defaults* + (make-pathname :directory dir :device (pathname-device pathname))) + (dev (pathname-device pathname))) + (loop for i from (case dev (:unc 3) (otherwise 2)) + upto (length dir) + do + (let* ((newpath (make-pathname + :host (pathname-host pathname) + :device dev + :directory (subseq dir 0 i))) + (probed (probe-file newpath))) + (unless (directory-pathname-p probed) + (let ((namestring (coerce (native-namestring newpath) + 'string))) + (when verbose + (format *standard-output* + "~&creating directory: ~A~%" + namestring)) + (sb!unix:unix-mkdir namestring mode) + (unless (directory-pathname-p (probe-file newpath)) + (restart-case + (error + 'simple-file-error + :pathname pathspec + :format-control + (if (and probed + (not (directory-pathname-p probed))) + "Can't create directory ~A,~ + ~%a file with the same name already exists." + "Can't create directory ~A") + :format-arguments (list namestring)) + (retry () + :report "Retry directory creation." + (ensure-directories-exist + pathspec + :verbose verbose :mode mode)) + (continue () + :report + "Continue as if directory creation was successful." + nil))) + (setf created-p t))))) (values pathspec created-p)))) (/show0 "filesys.lisp 1000")