X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=4c2c05355337c2afeec49b383242ce31d7ae2c33;hb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;hp=1b82730902ab1846c20f78c98a501077d583a7dd;hpb=6584a2c88efaa6931083721adae2f9f10e0fefd5;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 1b82730..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)) @@ -476,45 +480,202 @@ (1 (first matches)) (t (bug "!ENUMERATE-MATCHES returned more than one match on a non-wild pathname"))))) -;;;; TRUENAME and PROBE-FILE +;;;; TRUENAME, PROBE-FILE, FILE-AUTHOR, FILE-WRITE-DATE. -;;; This is only trivially different from PROBE-FILE, which is silly -;;; but ANSI. -(defun truename (pathname) - #!+sb-doc - "Return the pathname for the actual file described by PATHNAME. -An error of type FILE-ERROR is signalled if no such file exists, or the -pathname is wild. - -Under Unix, the TRUENAME of a broken symlink is considered to be the name of -the broken symlink itself." - (let ((result (probe-file pathname))) - (unless result +;;; Rewritten in 12/2007 by RMK, replacing 13+ year old CMU code that +;;; made a mess of things in order to support search lists (which SBCL +;;; has never had). These are now all relatively straightforward +;;; wrappers around stat(2) and realpath(2), with the same basic logic +;;; in all cases. The wrinkles to be aware of: +;;; +;;; * SBCL defines the truename of an existing, dangling or +;;; self-referring symlink to be the symlink itself. +;;; * The old version of PROBE-FILE merged the pathspec against +;;; *DEFAULT-PATHNAME-DEFAULTS* twice, and so lost when *D-P-D* +;;; was a relative pathname. Even if the case where *D-P-D* is a +;;; relative pathname is problematic, there's no particular reason +;;; to get that wrong, so let's try not to. +;;; * Note that while stat(2) is probably atomic, getting the truename +;;; for a filename involves poking all over the place, and so is +;;; subject to race conditions if other programs mutate the file +;;; system while we're resolving symlinks. So it's not implausible for +;;; realpath(3) to fail even if stat(2) succeeded. There's nothing +;;; obvious we can do about this, however. +;;; * Windows' apparent analogue of realpath(3) is called +;;; GetFullPathName, and it's a bit less useful than realpath(3). +;;; In particular, while realpath(3) errors in case the file doesn't +;;; exist, GetFullPathName seems to return a filename in all cases. +;;; 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. +;;; +;;; 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) + (sane-default-pathname-defaults))))) + (when (wild-pathname-p pathname) (error 'simple-file-error :pathname pathname - :format-control "The file ~S does not exist." - :format-arguments (list (namestring pathname)))) - result)) + :format-control "~@" + :format-arguments (list query-for pathname pathspec))) + (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 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 +a pathname that denotes a canonicalized name for the file. If +pathspec is a stream associated with a file, return a pathname +that denotes a canonicalized name for the file associated with +the stream. + +An error of type FILE-ERROR is signalled if no such file exists +or if the file system is such that a canonicalized file name +cannot be determined or if the pathname is wild. + +Under Unix, the TRUENAME of a symlink that links to itself or to +a file that doesn't exist is considered to be the name of the +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) + (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 :author)) -(defun probe-file (pathname) +(defun file-write-date (pathspec) #!+sb-doc - "Return a pathname which is the truename of the file if it exists, or NIL -otherwise. An error of type FILE-ERROR is signaled if pathname is wild." - (let* ((defaulted-pathname (merge-pathnames - pathname - (sane-default-pathname-defaults))) - (namestring (unix-namestring defaulted-pathname t))) - (when (and namestring (sb!unix:unix-file-kind namestring t)) - (let ((trueishname (sb!unix:unix-resolve-links namestring))) - (when trueishname - (let* ((*ignore-wildcards* t) - (name (simplify-namestring - trueishname - (pathname-host defaulted-pathname)))) - (if (eq (sb!unix:unix-file-kind name) :directory) - ;; FIXME: this might work, but it's ugly. - (pathname (concatenate 'string name "/")) - (pathname name)))))))) + "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)) ;;;; miscellaneous other operations @@ -561,20 +722,15 @@ otherwise. An error of type FILE-ERROR is signaled if pathname is wild." (simple-file-perror "couldn't delete ~A" namestring err)))) t) -(defun ensure-trailing-slash (string) - (let ((last-char (char string (1- (length string))))) - (if (or (eql last-char #\/) - #!+win32 - (eql last-char #\\)) - string - (concatenate 'string string "/")))) - (defun sbcl-homedir-pathname () (let ((sbcl-home (posix-getenv "SBCL_HOME"))) ;; SBCL_HOME isn't set for :EXECUTABLE T embedded cores - (when sbcl-home - (parse-native-namestring - (ensure-trailing-slash sbcl-home))))) + (when (and sbcl-home (not (string= sbcl-home ""))) + (parse-native-namestring sbcl-home + #!-win32 sb!impl::*unix-host* + #!+win32 sb!impl::*win32-host* + *default-pathname-defaults* + :as-directory t)))) ;;; (This is an ANSI Common Lisp function.) (defun user-homedir-pathname (&optional host) @@ -584,45 +740,23 @@ environment variable has been specified, the directory it designates is returned; otherwise obtains the home directory from the operating system." (declare (ignore host)) - (parse-native-namestring - (ensure-trailing-slash - (if (posix-getenv "HOME") - (posix-getenv "HOME") - #!-win32 - (sb!unix:uid-homedir (sb!unix:unix-getuid)) - #!+win32 - ;; Needs to bypass PARSE-NATIVE-NAMESTRING & ENSURE-TRAILING-SLASH - (return-from user-homedir-pathname - (sb!win32::get-folder-pathname sb!win32::csidl_profile)))))) - -(defun file-write-date (file) - #!+sb-doc - "Return file's creation date, or NIL if it doesn't exist. - An error of type file-error is signaled if file is a wild pathname" - (let ((name (unix-namestring file t))) - (when name - (multiple-value-bind - (res dev ino mode nlink uid gid rdev size atime mtime) - (sb!unix:unix-stat name) - (declare (ignore dev ino mode nlink uid gid rdev size atime)) - (when res - (+ unix-to-universal-time mtime)))))) - -(defun file-author (file) - #!+sb-doc - "Return the file author as a string, or NIL if the author cannot be - determined. Signal an error of type FILE-ERROR if FILE doesn't exist, - or FILE is a wild pathname." - (let ((name (unix-namestring (pathname file) t))) - (unless name - (error 'simple-file-error - :pathname file - :format-control "~S doesn't exist." - :format-arguments (list file))) - (multiple-value-bind (winp dev ino mode nlink uid) - (sb!unix:unix-stat name) - (declare (ignore dev ino mode nlink)) - (and winp (sb!unix:uid-username uid))))) + (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)))) + ;;;; DIRECTORY @@ -655,6 +789,41 @@ system." ;;; case when we call it), but there are other pitfalls as well: see ;;; the DIRECTORY-HELPER below for some, but others include a lack of ;;; pattern handling. + +;;; The above was written by CSR, I (RMK) believe. The argument that +;;; motivates the interpretation is faulty, however: PATHNAME-MATCH-P +;;; returns true for (PATHNAME-MATCH-P #P"/tmp/*/" #P"/tmp/../"), but +;;; the latter pathname is not in the result of DIRECTORY on the +;;; former. Indeed, if DIRECTORY were constrained to return the +;;; truename for every pathname for which PATHNAME-MATCH-P returned +;;; true and which denoted a filename that named an existing file, +;;; (DIRECTORY #P"/tmp/**/") would be required to list every file on a +;;; Unix system, since any file can be named as though it were "below" +;;; /tmp, given the dotdot entries. So I think the strongest +;;; "consistency" we can define between PATHNAME-MATCH-P and DIRECTORY +;;; is that PATHNAME-MATCH-P returns true of everything DIRECTORY +;;; returns, but not vice versa. + +;;; In any case, even if the motivation were sound, DIRECTORY on a +;;; wild logical pathname has no portable semantics. I see nothing in +;;; ANSI that requires implementations to support wild physical +;;; pathnames, and so there need not be any translation of a wild +;;; logical pathname to a phyiscal pathname. So a program that calls +;;; DIRECTORY on a wild logical pathname is doing something +;;; non-portable at best. And if the only sensible semantics for +;;; DIRECTORY on a wild logical pathname is something like the +;;; following, it would be just as well if it signaled an error, since +;;; a program can't possibly rely on the result of an intersection of +;;; user-defined translations with a file system probe. (Potentially +;;; useful kinds of "pathname" that might not support wildcards could +;;; include pathname hosts that model unqueryable namespaces like HTTP +;;; URIs, or that model namespaces that it's not convenient to +;;; investigate, such as the namespace of TCP ports that some network +;;; host listens on. I happen to think it a bad idea to try to +;;; shoehorn such namespaces into a pathnames system, but people +;;; sometimes claim to want pathnames for these things.) -- RMK +;;; 2007-12-31. + (defun pathname-intersections (one two) (aver (logical-pathname-p one)) (aver (logical-pathname-p two)) @@ -770,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))) @@ -796,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)))) @@ -816,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))) @@ -855,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))))