X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=4c2c05355337c2afeec49b383242ce31d7ae2c33;hb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;hp=c831ec575721faaba06baa5918b1921af52419a1;hpb=6bbc22725d3bf663726ed9adca544e39316364a6;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index c831ec5..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) +;;; +;;; 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,105 +527,120 @@ :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 (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 - (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 - (nth-value - 0 + (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 - (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; error. - (simple-file-perror - (format nil "failed to find the ~A of ~~A" query-for) - pathspec errno))))))) + 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 the truename can be found, or NIL otherwise. See TRUENAME for more information." - (handler-case (truename pathspec) (file-error () nil))) + (query-file-system pathspec :truename nil)) (defun truename (pathspec) #!+sb-doc @@ -700,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)))) @@ -714,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 @@ -910,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))) @@ -936,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)))) @@ -956,9 +988,9 @@ 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))))