+(defun directory (pathspec &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. 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)))
+ (labels ((record (pathname)
+ (let ((truename (if resolve-symlinks
+ ;; FIXME: Why not not TRUENAME? As reported by
+ ;; Milan Zamazal sbcl-devel 2003-10-05, using
+ ;; TRUENAME causes a race condition whereby
+ ;; removal of a file during the directory
+ ;; operation causes an error. It's not clear
+ ;; what the right thing to do is, though. --
+ ;; CSR, 2003-10-13
+ (query-file-system pathname :truename nil)
+ (query-file-system pathname :existence nil))))
+ (when truename
+ (setf (gethash (namestring truename) truenames)
+ truename))))
+ (do-physical-pathnames (pathname)
+ (aver (not (logical-pathname-p pathname)))
+ (let* (;; KLUDGE: Since we don't canonize pathnames on construction,
+ ;; we really have to do it here to get #p"foo/." mean the same
+ ;; as #p"foo/./".
+ (pathname (canonicalize-pathname pathname))
+ (name (pathname-name pathname))
+ (type (pathname-type pathname))
+ (match-name (make-matcher name))
+ (match-type (make-matcher type)))
+ (map-matching-directories
+ (if (or name type)
+ (lambda (directory)
+ (map-matching-entries #'record
+ directory
+ match-name
+ match-type))
+ #'record)
+ pathname)))
+ (do-pathnames (pathname)
+ (if (logical-pathname-p pathname)
+ (let ((host (intern-logical-host (pathname-host pathname))))
+ (dolist (x (logical-host-canon-transls host))
+ (destructuring-bind (from to) x
+ (let ((intersections
+ (pathname-intersections pathname from)))
+ (dolist (p intersections)
+ (do-pathnames (translate-pathname p from to)))))))
+ (do-physical-pathnames pathname))))
+ (declare (truly-dynamic-extent #'record))
+ (do-pathnames (merge-pathnames pathspec)))
+ (mapcar #'cdr
+ ;; Sorting isn't required by the ANSI spec, but sorting into some
+ ;; canonical order seems good just on the grounds that the
+ ;; implementation should have repeatable behavior when possible.
+ (sort (loop for namestring being each hash-key in truenames
+ using (hash-value truename)
+ collect (cons namestring truename))
+ #'string<
+ :key #'car))))
+
+(defun canonicalize-pathname (pathname)
+ ;; We're really only interested in :UNSPECIFIC -> NIL, :BACK and :UP,
+ ;; and dealing with #p"foo/.." and #p"foo/."
+ (labels ((simplify (piece)
+ (unless (eq :unspecific piece)
+ piece))
+ (canonicalize-directory (directory)
+ (let (pieces)
+ (dolist (piece directory)
+ (cond
+ ((and pieces (member piece '(:back :up)))
+ ;; FIXME: We should really canonicalize when we construct
+ ;; pathnames. This is just wrong.
+ (case (car pieces)
+ ((:absolute :wild-inferiors)
+ (error 'simple-file-error
+ :format-control "Invalid use of ~S after ~S."
+ :format-arguments (list piece (car pieces))
+ :pathname pathname))
+ ((:relative :up :back)
+ (push piece pieces))
+ (t
+ (pop pieces))))
+ ((equal piece ".")
+ ;; This case only really matters on Windows,
+ ;; because on POSIX, our call site (TRUENAME via
+ ;; QUERY-FILE-SYSTEM) only passes in pathnames from
+ ;; realpath(3), in which /./ has been removed
+ ;; already. Windows, however, depends on us to
+ ;; perform this fixup. -- DFL
+ )
+ (t
+ (push piece pieces))))
+ (nreverse pieces))))
+ (let ((name (simplify (pathname-name pathname)))
+ (type (simplify (pathname-type pathname)))
+ (dir (canonicalize-directory (pathname-directory pathname))))
+ (cond ((equal "." name)
+ (cond ((not type)
+ (make-pathname :name nil :defaults pathname))
+ ((equal "" type)
+ (make-pathname :name nil
+ :type nil
+ :directory (butlast dir)
+ :defaults pathname))))
+ (t
+ (make-pathname :name name :type type
+ :directory dir
+ :defaults pathname))))))
+
+;;; Given a native namestring, provides a WITH-HASH-TABLE-ITERATOR style
+;;; interface to mapping over namestrings of entries in the corresponding
+;;; directory.
+(defmacro with-native-directory-iterator ((iterator namestring &key errorp) &body body)
+ (with-unique-names (one-iter)
+ `(dx-flet
+ ((iterate (,one-iter)
+ (declare (type function ,one-iter))
+ (macrolet ((,iterator ()
+ `(funcall ,',one-iter)))
+ ,@body)))
+ #!+win32
+ (sb!win32::native-call-with-directory-iterator
+ #'iterate ,namestring ,errorp)
+ #!-win32
+ (call-with-native-directory-iterator #'iterate ,namestring ,errorp))))
+
+(defun call-with-native-directory-iterator (function namestring errorp)
+ (declare (type (or null string) namestring)
+ (function function))
+ (let (dp)
+ (when namestring
+ (dx-flet
+ ((one-iter ()
+ (tagbody
+ :next
+ (let ((ent (sb!unix:unix-readdir dp nil)))
+ (when ent
+ (let ((name (sb!unix:unix-dirent-name ent)))
+ (when name
+ (cond ((equal "." name)
+ (go :next))
+ ((equal ".." name)
+ (go :next))
+ (t
+ (return-from one-iter name))))))))))
+ (unwind-protect
+ (progn
+ (setf dp (sb!unix:unix-opendir namestring errorp))
+ (when dp
+ (funcall function #'one-iter)))
+ (when dp
+ (sb!unix:unix-closedir dp nil)))))))
+
+;;; This is our core directory access interface that we use to implement
+;;; DIRECTORY.
+(defun map-directory (function directory &key (files t) (directories t)
+ (classify-symlinks t) (errorp t))
+ #!+sb-doc
+ "Map over entries in DIRECTORY. Keyword arguments specify which entries to
+map over, and how:
+
+ :FILES
+ If true, call FUNCTION with the pathname of each file in DIRECTORY.
+ Defaults to T.
+
+ :DIRECTORIES
+ If true, call FUNCTION with a pathname for each subdirectory of DIRECTORY.
+ If :AS-FILES, the pathname used is a pathname designating the subdirectory
+ as a file in DIRECTORY. Otherwise the pathname used is a directory
+ pathname. Defaults to T.
+
+ :CLASSIFY-SYMLINKS
+ If true, the decision to call FUNCTION with the pathname of a symbolic link
+ depends on the resolution of the link: if it points to a directory, it is
+ considered a directory entry, otherwise a file entry. If false, all
+ symbolic links are considered file entries. In both cases the pathname used
+ for the symbolic link is not fully resolved, but names it as an immediate
+ child of DIRECTORY. Defaults to T.
+
+ :ERRORP
+ If true, signal an error if DIRECTORY does not exist, cannot be read, etc.
+ Defaults to T.
+
+Experimental: interface subject to change."
+ (declare (pathname-designator directory))
+ (let* ((fun (%coerce-callable-to-fun function))
+ (as-files (eq :as-files directories))
+ (physical (physicalize-pathname directory))
+ (realname (query-file-system physical :existence nil))
+ (canonical (if realname
+ (parse-native-namestring realname
+ (pathname-host physical)
+ (sane-default-pathname-defaults)
+ :as-directory t)
+ (return-from map-directory nil)))
+ (dirname (native-namestring canonical)))
+ (flet ((map-it (name dirp)
+ (funcall fun
+ (merge-pathnames (parse-native-namestring
+ name nil physical
+ :as-directory (and dirp (not as-files)))
+ physical))))
+ (with-native-directory-iterator (next dirname :errorp errorp)
+ (loop
+ ;; provision for FindFirstFileExW-based iterator that should be used
+ ;; on Windows: file kind is known instantly there, so we'll have it
+ ;; returned by (next) soon.
+ (multiple-value-bind (name kind) (next)
+ (unless (or name kind) (return))
+ (unless kind
+ (setf kind (native-file-kind
+ (concatenate 'string dirname name))))
+ (when kind
+ (case kind
+ (:directory
+ (when directories
+ (map-it name t)))
+ (:symlink
+ (if classify-symlinks
+ (let* ((tmpname (merge-pathnames
+ (parse-native-namestring
+ name nil physical :as-directory nil)
+ physical))
+ (truename (query-file-system tmpname :truename nil)))
+ (if (or (not truename)
+ (or (pathname-name truename) (pathname-type truename)))
+ (when files
+ (funcall fun tmpname))
+ (when directories
+ (map-it name t))))
+ (when files
+ (map-it name nil))))
+ (t
+ ;; Anything else parses as a file.
+ (when files
+ (map-it name nil)))))))))))
+
+;;; Part of DIRECTORY: implements matching the directory spec. Calls FUNCTION
+;;; with all DIRECTORIES that match the directory portion of PATHSPEC.
+(defun map-matching-directories (function pathspec)
+ (let* ((dir (pathname-directory pathspec))
+ (length (length dir))
+ (wild (position-if (lambda (elt)
+ (or (eq :wild elt) (typep elt 'pattern)))
+ dir))
+ (wild-inferiors (position :wild-inferiors dir))
+ (end (cond ((and wild wild-inferiors)
+ (min wild wild-inferiors))
+ (t
+ (or wild wild-inferiors length))))
+ (rest (subseq dir end))
+ (starting-point (make-pathname :directory (subseq dir 0 end)
+ :device (pathname-device pathspec)
+ :host (pathname-host pathspec)
+ :name nil
+ :type nil
+ :version nil)))
+ (cond (wild-inferiors
+ (map-wild-inferiors function rest starting-point))
+ (wild
+ (map-wild function rest starting-point))
+ (t
+ ;; Nothing wild -- the directory matches itself.
+ (funcall function starting-point))))
+ nil)
+
+(defun last-directory-piece (pathname)
+ (car (last (pathname-directory pathname))))
+
+;;; Part of DIRECTORY: implements iterating over a :WILD or pattern component
+;;; in the directory spec.
+(defun map-wild (function more directory)
+ (let ((this (pop more))
+ (next (car more)))
+ (flet ((cont (subdirectory)
+ (cond ((not more)
+ ;; end of the line
+ (funcall function subdirectory))
+ ((or (eq :wild next) (typep next 'pattern))
+ (map-wild function more subdirectory))
+ ((eq :wild-inferiors next)
+ (map-wild-inferiors function more subdirectory))
+ (t
+ (let ((this (pathname-directory subdirectory)))
+ (map-matching-directories
+ function
+ (make-pathname :directory (append this more)
+ :defaults subdirectory)))))))
+ (map-directory
+ (if (eq :wild this)
+ #'cont
+ (lambda (sub)
+ (when (pattern-matches this (last-directory-piece sub))
+ (funcall #'cont sub))))
+ directory
+ :files nil
+ :directories t
+ :errorp nil))))
+
+;;; Part of DIRECTORY: implements iterating over a :WILD-INFERIORS component
+;;; in the directory spec.
+(defun map-wild-inferiors (function more directory)
+ (loop while (member (car more) '(:wild :wild-inferiors))
+ do (pop more))
+ (let ((next (car more))
+ (rest (cdr more)))
+ (unless more
+ (funcall function directory))
+ (map-directory
+ (cond ((not more)
+ (lambda (pathname)
+ (funcall function pathname)
+ (map-wild-inferiors function more pathname)))
+ (t
+ (lambda (pathname)
+ (let ((this (pathname-directory pathname)))
+ (when (equal next (car (last this)))
+ (map-matching-directories
+ function
+ (make-pathname :directory (append this rest)
+ :defaults pathname)))
+ (map-wild-inferiors function more pathname)))))
+ directory
+ :files nil
+ :directories t
+ :errorp nil)))
+
+;;; Part of DIRECTORY: implements iterating over entries in a directory, and
+;;; matching them.
+(defun map-matching-entries (function directory match-name match-type)
+ (map-directory
+ (lambda (file)
+ (when (and (funcall match-name (pathname-name file))
+ (funcall match-type (pathname-type file)))
+ (funcall function file)))
+ directory
+ :files t
+ :directories :as-files
+ :errorp nil))