X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=4c2c05355337c2afeec49b383242ce31d7ae2c33;hb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;hp=4e858abcc49c1a5f36becac186f1c94c2836fc1f;hpb=7c4ec3d38ceb696c86e403e4f8a250749462445d;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 4e858ab..4c2c053 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -198,6 +198,10 @@ (/show0 "filesys.lisp 498") +;; TODO: the implementation !enumerate-matches is some hairy stuff +;; that we mostly don't need. Couldn't we use POSIX fts(3) to walk +;; the file system and PATHNAME-MATCH-P to select matches, at least on +;; Unices? (defmacro !enumerate-matches ((var pathname &optional result &key (verify-existence t) (follow-links t)) @@ -504,7 +508,15 @@ ;;; As realpath(3) is not atomic anyway, we only ever call it when ;;; we think a file exists, so just be careful when rewriting this ;;; routine. -(defun query-file-system (pathspec query-for enoent-errorp) +;;; +;;; Given a pathname designator, some quality to query for, return one +;;; of a pathname, a universal time, or a string (a file-author), or +;;; NIL. QUERY-FOR may be one of :TRUENAME, :EXISTENCE, :WRITE-DATE, +;;; :AUTHOR. If ERRORP is false, return NIL in case the file system +;;; returns an error code; otherwise, signal an error. Accepts +;;; logical pathnames, too (but never returns LPNs). For internal +;;; use. +(defun query-file-system (pathspec query-for &optional (errorp t)) (let ((pathname (translate-logical-pathname (merge-pathnames (pathname pathspec) @@ -515,110 +527,121 @@ :format-control "~@" :format-arguments (list query-for pathname pathspec))) - (let ((filename (native-namestring pathname :as-file t))) - (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)) - (if existsp - (case query-for - (:truename (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 - (simple-file-perror "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 (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 ELOOP in this case, 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 - (: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-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 - (simple-file-perror "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; return - ;; NIL or error. - (if (and (= errno sb!unix:enoent) (not enoent-errorp)) - nil - (simple-file-perror - (format nil "failed to find the ~A of ~~A" query-for) - pathspec errno)))))))) + (flet ((fail (note-format pathname errno) + (if errorp + (simple-file-perror note-format pathname errno) + (return-from query-file-system nil)))) + (let ((filename (native-namestring pathname :as-file t))) + (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)) + (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 (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)))))))) (defun probe-file (pathspec) #!+sb-doc - "Return the truename of PATHSPEC if such a file exists, the -coercion of PATHSPEC to a pathname if PATHSPEC names a symlink -that links to itself or to a file that doesn't exist, or NIL if -errno is set to ENOENT after trying to stat(2) the file. An -error of type FILE-ERROR is signaled if PATHSPEC is a wild -pathname, or for any other circumstance where stat(2) fails." + "Return the truename of PATHSPEC if the truename can be found, +or NIL otherwise. See TRUENAME for more information." (query-file-system pathspec :truename nil)) - (defun truename (pathspec) #!+sb-doc "If PATHSPEC is a pathname that names an existing file, return @@ -637,22 +660,22 @@ broken symlink itself." ;; Note that eventually this routine might be different for streams ;; than for other pathname designators. (if (streamp pathspec) - (query-file-system pathspec :truename t) - (query-file-system pathspec :truename t))) + (query-file-system pathspec :truename) + (query-file-system pathspec :truename))) (defun file-author (pathspec) #!+sb-doc "Return the author of the file specified by PATHSPEC. Signal an error of type FILE-ERROR if no such file exists, or if PATHSPEC is a wild pathname." - (query-file-system pathspec :write-date t)) + (query-file-system pathspec :author)) (defun file-write-date (pathspec) #!+sb-doc "Return the write date of the file specified by PATHSPEC. An error of type FILE-ERROR is signaled if no such file exists, or if PATHSPEC is a wild pathname." - (query-file-system pathspec :write-date t)) + (query-file-system pathspec :write-date)) ;;;; miscellaneous other operations @@ -704,8 +727,8 @@ or if PATHSPEC is a wild pathname." ;; SBCL_HOME isn't set for :EXECUTABLE T embedded cores (when (and sbcl-home (not (string= sbcl-home ""))) (parse-native-namestring sbcl-home - #-win32 sb!impl::*unix-host* - #+win32 sb!impl::*win32-host* + #!-win32 sb!impl::*unix-host* + #!+win32 sb!impl::*win32-host* *default-pathname-defaults* :as-directory t)))) @@ -718,20 +741,22 @@ is returned; otherwise obtains the home directory from the operating system." (declare (ignore host)) (let ((env-home (posix-getenv "HOME"))) - (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 + (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)))) + ;;;; DIRECTORY @@ -914,18 +939,19 @@ system." (car one) (car two)) x)) (intersect-directory-helper (cdr one) (cdr two))))))))) -(defun directory (pathname &key) +(defun directory (pathname &key (resolve-symlinks t)) #!+sb-doc "Return a list of PATHNAMEs, each the TRUENAME of a file that matched the given pathname. Note that the interaction between this ANSI-specified TRUENAMEing and the semantics of the Unix filesystem (symbolic links..) means this function can sometimes return files which don't have the same - directory as PATHNAME." + directory as PATHNAME. If :RESOLVE-SYMLINKS is NIL, don't resolve + symbolic links in matching filenames." (let (;; We create one entry in this hash table for each truename, ;; as an asymptotically efficient way of removing duplicates ;; (which can arise when e.g. multiple symlinks map to the ;; same truename). - (truenames (make-hash-table :test #'equal)) + (filenames (make-hash-table :test #'equal)) ;; FIXME: Possibly this MERGE-PATHNAMES call should only ;; happen once we get a physical pathname. (merged-pathname (merge-pathnames pathname))) @@ -940,10 +966,12 @@ system." ;; operation causes an error. It's not clear ;; what the right thing to do is, though. -- ;; CSR, 2003-10-13 - (truename (probe-file match))) - (when truename - (setf (gethash (namestring truename) truenames) - truename))))) + (filename (if resolve-symlinks + (query-file-system match :truename nil) + (query-file-system match :existence nil)))) + (when filename + (setf (gethash (namestring filename) filenames) + filename))))) (do-directory (pathname) (if (logical-pathname-p pathname) (let ((host (intern-logical-host (pathname-host pathname)))) @@ -960,15 +988,17 @@ system." ;; into some canonical order seems good just on the ;; grounds that the implementation should have repeatable ;; behavior when possible. - (sort (loop for name being each hash-key in truenames - using (hash-value truename) - collect (cons name truename)) + (sort (loop for name being each hash-key in filenames + using (hash-value filename) + collect (cons name filename)) #'string< :key #'car)))) (/show0 "filesys.lisp 899") ;;; predicate to order pathnames by; goes by name +;; FIXME: Does anything use this? It's not exported, and I don't find +;; the name anywhere else. (defun pathname-order (x y) (let ((xn (%pathname-name x)) (yn (%pathname-name y))) @@ -999,22 +1029,28 @@ system." :device (pathname-device pathname) :directory (subseq dir 0 i)))) (unless (probe-file newpath) - (let ((namestring (coerce (namestring newpath) 'string))) + (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 namestring) - (restart-case (error 'simple-file-error - :pathname pathspec - :format-control "can't create directory ~A" - :format-arguments (list namestring)) + (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)) + (ensure-directories-exist + pathspec + :verbose verbose :mode mode)) (continue () - :report "Continue as if directory creation was successful." + :report + "Continue as if directory creation was successful." nil))) (setf created-p t))))) (values pathspec created-p))))