(/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))
;;; 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)
:format-control "~@<can't find the ~A of wild pathname ~A~
(physicalized from ~A).~:>"
: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; 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))))))))
+ 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
;; 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 :author 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))
\f
;;;; miscellaneous other operations
;; 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))))
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))))
+
\f
;;;; DIRECTORY
(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)))
;; 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))))
;; 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))))
\f
projects / sbcl.git / blobdiff