-;;; Call FUNCTION on directories.
-(defun %enumerate-directories (head tail pathname verify-existence
- follow-links nodes function)
- (declare (simple-string head))
- (macrolet ((unix-xstat (name)
- `(if follow-links
- (sb!unix:unix-stat ,name)
- (sb!unix:unix-lstat ,name)))
- (with-directory-node-noted ((head) &body body)
- `(multiple-value-bind (res dev ino mode)
- (unix-xstat ,head)
- (when (and res (eql (logand mode sb!unix:s-ifmt)
- sb!unix:s-ifdir))
- (let ((nodes (cons (cons dev ino) nodes)))
- ,@body)))))
- (if tail
- (let ((piece (car tail)))
- (etypecase piece
- (simple-string
- (let ((head (concatenate 'string head piece)))
- (with-directory-node-noted (head)
- (%enumerate-directories (concatenate 'string head "/")
- (cdr tail) pathname
- verify-existence follow-links
- nodes function))))
- ((member :wild-inferiors)
- (%enumerate-directories head (rest tail) pathname
- verify-existence follow-links
- nodes function)
- (dolist (name (ignore-errors (directory-lispy-filenames head)))
- (let ((subdir (concatenate 'string head name)))
- (multiple-value-bind (res dev ino mode)
- (unix-xstat subdir)
- (declare (type (or fixnum null) mode))
- (when (and res (eql (logand mode sb!unix:s-ifmt)
- sb!unix:s-ifdir))
- (unless (dolist (dir nodes nil)
- (when (and (eql (car dir) dev)
- (eql (cdr dir) ino))
- (return t)))
- (let ((nodes (cons (cons dev ino) nodes))
- (subdir (concatenate 'string subdir "/")))
- (%enumerate-directories subdir tail pathname
- verify-existence follow-links
- nodes function))))))))
- ((or pattern (member :wild))
- (dolist (name (directory-lispy-filenames head))
- (when (or (eq piece :wild) (pattern-matches piece name))
- (let ((subdir (concatenate 'string head name)))
- (multiple-value-bind (res dev ino mode)
- (unix-xstat subdir)
- (declare (type (or fixnum null) mode))
- (when (and res
- (eql (logand mode sb!unix:s-ifmt)
- sb!unix:s-ifdir))
- (let ((nodes (cons (cons dev ino) nodes))
- (subdir (concatenate 'string subdir "/")))
- (%enumerate-directories subdir (rest tail) pathname
- verify-existence follow-links
- nodes function))))))))
- ((member :up)
- (let ((head (concatenate 'string head "..")))
- (with-directory-node-noted (head)
- (%enumerate-directories (concatenate 'string head "/")
- (rest tail) pathname
- verify-existence follow-links
- nodes function))))))
- (%enumerate-files head pathname verify-existence function))))
+;;; 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 "~@<can't find the ~A of wild pathname ~A~
+ (physicalized from ~A).~:>"
+ :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
+ #!+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))))))))