+ (when pathname
+ (let ((pathname (pathname pathname)))
+ (flet ((check-one (x)
+ (member x '(nil :unspecific "") :test 'equal)))
+ (and (not (wild-pathname-p pathname))
+ (check-one (pathname-name pathname))
+ (check-one (pathname-type pathname))
+ t)))))
+
+ (defun ensure-directory-pathname (pathspec &optional (on-error 'error))
+ "Converts the non-wild pathname designator PATHSPEC to directory form."
+ (cond
+ ((stringp pathspec)
+ (ensure-directory-pathname (pathname pathspec)))
+ ((not (pathnamep pathspec))
+ (call-function on-error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
+ ((wild-pathname-p pathspec)
+ (call-function on-error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
+ ((directory-pathname-p pathspec)
+ pathspec)
+ (t
+ (make-pathname* :directory (append (or (normalize-pathname-directory-component
+ (pathname-directory pathspec))
+ (list :relative))
+ (list (file-namestring pathspec)))
+ :name nil :type nil :version nil :defaults pathspec)))))
+
+
+;;; Parsing filenames
+(with-upgradability ()
+ (defun split-unix-namestring-directory-components
+ (unix-namestring &key ensure-directory dot-dot)
+ "Splits the path string UNIX-NAMESTRING, returning four values:
+A flag that is either :absolute or :relative, indicating
+ how the rest of the values are to be interpreted.
+A directory path --- a list of strings and keywords, suitable for
+ use with MAKE-PATHNAME when prepended with the flag value.
+ Directory components with an empty name or the name . are removed.
+ Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP).
+A last-component, either a file-namestring including type extension,
+ or NIL in the case of a directory pathname.
+A flag that is true iff the unix-style-pathname was just
+ a file-namestring without / path specification.
+ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname:
+the third return value will be NIL, and final component of the namestring
+will be treated as part of the directory path.
+
+An empty string is thus read as meaning a pathname object with all fields nil.
+
+Note that : characters will NOT be interpreted as host specification.
+Absolute pathnames are only appropriate on Unix-style systems.
+
+The intention of this function is to support structured component names,
+e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
+ (check-type unix-namestring string)
+ (check-type dot-dot (member nil :back :up))
+ (if (and (not (find #\/ unix-namestring)) (not ensure-directory)
+ (plusp (length unix-namestring)))
+ (values :relative () unix-namestring t)
+ (let* ((components (split-string unix-namestring :separator "/"))
+ (last-comp (car (last components))))
+ (multiple-value-bind (relative components)
+ (if (equal (first components) "")
+ (if (equal (first-char unix-namestring) #\/)
+ (values :absolute (cdr components))
+ (values :relative nil))
+ (values :relative components))
+ (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal))
+ components))
+ (setf components (substitute (or dot-dot :back) ".." components :test #'equal))
+ (cond
+ ((equal last-comp "")
+ (values relative components nil nil)) ; "" already removed from components
+ (ensure-directory
+ (values relative components nil nil))
+ (t
+ (values relative (butlast components) last-comp nil)))))))
+
+ (defun split-name-type (filename)
+ "Split a filename into two values NAME and TYPE that are returned.
+We assume filename has no directory component.
+The last . if any separates name and type from from type,
+except that if there is only one . and it is in first position,
+the whole filename is the NAME with an empty type.
+NAME is always a string.
+For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned."
+ (check-type filename string)
+ (assert (plusp (length filename)))
+ (destructuring-bind (name &optional (type *unspecific-pathname-type*))
+ (split-string filename :max 2 :separator ".")
+ (if (equal name "")
+ (values filename *unspecific-pathname-type*)
+ (values name type))))
+
+ (defun parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory
+ &allow-other-keys)
+ "Coerce NAME into a PATHNAME using standard Unix syntax.
+
+Unix syntax is used whether or not the underlying system is Unix;
+on such non-Unix systems it is only usable but for relative pathnames;
+but especially to manipulate relative pathnames portably, it is of crucial
+to possess a portable pathname syntax independent of the underlying OS.
+This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
+
+When given a PATHNAME object, just return it untouched.
+When given NIL, just return NIL.
+When given a non-null SYMBOL, first downcase its name and treat it as a string.
+When given a STRING, portably decompose it into a pathname as below.
+
+#\\/ separates directory components.
+
+The last #\\/-separated substring is interpreted as follows:
+1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true,
+ the string is made the last directory component, and NAME and TYPE are NIL.
+ if the string is empty, it's the empty pathname with all slots NIL.
+2- If TYPE is NIL, the substring is file-namestring, and its NAME and TYPE
+ are separated by SPLIT-NAME-TYPE.
+3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
+
+Directory components with an empty name the name . are removed.
+Any directory named .. is read as DOT-DOT,
+which must be one of :BACK or :UP and defaults to :BACK.
+
+HOST, DEVICE and VERSION components are taken from DEFAULTS,
+which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS in NIL.
+No host or device can be specified in the string itself,
+which makes it unsuitable for absolute pathnames outside Unix.
+
+For relative pathnames, these components (and hence the defaults) won't matter
+if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES,
+which is an important reason to always use MERGE-PATHNAMES*.
+
+Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME
+with those keys, removing TYPE DEFAULTS and DOT-DOT.
+When you're manipulating pathnames that are supposed to make sense portably
+even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T
+to throw an error if the pathname is absolute"
+ (block nil
+ (check-type type (or null string (eql :directory)))
+ (when ensure-directory
+ (setf type :directory))
+ (etypecase name
+ ((or null pathname) (return name))
+ (symbol
+ (setf name (string-downcase name)))
+ (string))
+ (multiple-value-bind (relative path filename file-only)
+ (split-unix-namestring-directory-components
+ name :dot-dot dot-dot :ensure-directory (eq type :directory))
+ (multiple-value-bind (name type)
+ (cond
+ ((or (eq type :directory) (null filename))
+ (values nil nil))
+ (type
+ (values filename type))
+ (t
+ (split-name-type filename)))
+ (apply 'ensure-pathname
+ (make-pathname*
+ :directory (unless file-only (cons relative path))
+ :name name :type type
+ :defaults (or #-mcl defaults *nil-pathname*))
+ (remove-plist-keys '(:type :dot-dot :defaults) keys))))))
+
+ (defun unix-namestring (pathname)
+ "Given a non-wild PATHNAME, return a Unix-style namestring for it.
+If the PATHNAME is NIL or a STRING, return it unchanged.
+
+This only considers the DIRECTORY, NAME and TYPE components of the pathname.
+This is a portable solution for representing relative pathnames,
+But unless you are running on a Unix system, it is not a general solution
+to representing native pathnames.
+
+An error is signaled if the argument is not NULL, a STRING or a PATHNAME,
+or if it is a PATHNAME but some of its components are not recognized."
+ (etypecase pathname
+ ((or null string) pathname)
+ (pathname
+ (with-output-to-string (s)
+ (flet ((err () (error "Not a valid unix-namestring ~S" pathname)))
+ (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
+ (name (pathname-name pathname))
+ (type (pathname-type pathname))
+ (type (and (not (eq type :unspecific)) type)))
+ (cond
+ ((eq dir ()))
+ ((eq dir '(:relative)) (princ "./" s))
+ ((consp dir)
+ (destructuring-bind (relabs &rest dirs) dir
+ (or (member relabs '(:relative :absolute)) (err))
+ (when (eq relabs :absolute) (princ #\/ s))
+ (loop :for x :in dirs :do
+ (cond
+ ((member x '(:back :up)) (princ "../" s))
+ ((equal x "") (err))
+ ;;((member x '("." "..") :test 'equal) (err))
+ ((stringp x) (format s "~A/" x))
+ (t (err))))))
+ (t (err)))
+ (cond
+ (name
+ (or (and (stringp name) (or (null type) (stringp type))) (err))
+ (format s "~A~@[.~A~]" name type))
+ (t
+ (or (null type) (err)))))))))))
+
+;;; Absolute and relative pathnames
+(with-upgradability ()
+ (defun subpathname (pathname subpath &key type)
+ "This function takes a PATHNAME and a SUBPATH and a TYPE.
+If SUBPATH is already a PATHNAME object (not namestring),
+and is an absolute pathname at that, it is returned unchanged;
+otherwise, SUBPATH is turned into a relative pathname with given TYPE
+as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE,
+then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
+ (or (and (pathnamep subpath) (absolute-pathname-p subpath))
+ (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t)
+ (pathname-directory-pathname pathname))))
+
+ (defun subpathname* (pathname subpath &key type)
+ "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME."
+ (and pathname
+ (subpathname (ensure-directory-pathname pathname) subpath :type type)))
+
+ (defun pathname-root (pathname)
+ (make-pathname* :directory '(:absolute)
+ :name nil :type nil :version nil
+ :defaults pathname ;; host device, and on scl, *some*
+ ;; scheme-specific parts: port username password, not others:
+ . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
+
+ (defun pathname-host-pathname (pathname)
+ (make-pathname* :directory nil
+ :name nil :type nil :version nil :device nil
+ :defaults pathname ;; host device, and on scl, *some*
+ ;; scheme-specific parts: port username password, not others:
+ . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
+
+ (defun subpathp (maybe-subpath base-pathname)
+ (and (pathnamep maybe-subpath) (pathnamep base-pathname)
+ (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
+ (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
+ (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
+ (with-pathname-defaults ()
+ (let ((enough (enough-namestring maybe-subpath base-pathname)))
+ (and (relative-pathname-p enough) (pathname enough))))))
+
+ (defun ensure-absolute-pathname (path &optional defaults (on-error 'error))
+ (cond
+ ((absolute-pathname-p path))
+ ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error))
+ ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path))
+ ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults))))
+ (or (if (absolute-pathname-p default-pathname)
+ (absolute-pathname-p (merge-pathnames* path default-pathname))
+ (call-function on-error "Default pathname ~S is not an absolute pathname"
+ default-pathname))
+ (call-function on-error "Failed to merge ~S with ~S into an absolute pathname"
+ path default-pathname))))
+ (t (call-function on-error
+ "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
+ path defaults)))))
+
+
+;;; Wildcard pathnames
+(with-upgradability ()
+ (defparameter *wild* (or #+cormanlisp "*" :wild))
+ (defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild))
+ (defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors))
+ (defparameter *wild-file*
+ (make-pathname :directory nil :name *wild* :type *wild*
+ :version (or #-(or allegro abcl xcl) *wild*)))
+ (defparameter *wild-directory*
+ (make-pathname* :directory `(:relative ,*wild-directory-component*)
+ :name nil :type nil :version nil))
+ (defparameter *wild-inferiors*
+ (make-pathname* :directory `(:relative ,*wild-inferiors-component*)
+ :name nil :type nil :version nil))
+ (defparameter *wild-path*
+ (merge-pathnames* *wild-file* *wild-inferiors*))
+
+ (defun wilden (path)
+ (merge-pathnames* *wild-path* path)))
+
+
+;;; Translate a pathname
+(with-upgradability ()
+ (defun relativize-directory-component (directory-component)
+ (let ((directory (normalize-pathname-directory-component directory-component)))
+ (cond
+ ((stringp directory)
+ (list :relative directory))
+ ((eq (car directory) :absolute)
+ (cons :relative (cdr directory)))
+ (t
+ directory))))
+
+ (defun relativize-pathname-directory (pathspec)
+ (let ((p (pathname pathspec)))
+ (make-pathname*
+ :directory (relativize-directory-component (pathname-directory p))
+ :defaults p)))
+
+ (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
+ (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname)))
+ (last-char (namestring foo))))
+
+ #-scl
+ (defun directorize-pathname-host-device (pathname)
+ #+(or unix abcl)
+ (when (and #+abcl (os-unix-p) (physical-pathname-p pathname))
+ (return-from directorize-pathname-host-device pathname))
+ (let* ((root (pathname-root pathname))
+ (wild-root (wilden root))
+ (absolute-pathname (merge-pathnames* pathname root))
+ (separator (directory-separator-for-host root))
+ (root-namestring (namestring root))
+ (root-string
+ (substitute-if #\/
+ #'(lambda (x) (or (eql x #\:)
+ (eql x separator)))
+ root-namestring)))
+ (multiple-value-bind (relative path filename)
+ (split-unix-namestring-directory-components root-string :ensure-directory t)
+ (declare (ignore relative filename))
+ (let ((new-base
+ (make-pathname* :defaults root :directory `(:absolute ,@path))))
+ (translate-pathname absolute-pathname wild-root (wilden new-base))))))
+
+ #+scl
+ (defun directorize-pathname-host-device (pathname)
+ (let ((scheme (ext:pathname-scheme pathname))
+ (host (pathname-host pathname))
+ (port (ext:pathname-port pathname))
+ (directory (pathname-directory pathname)))
+ (flet ((specificp (x) (and x (not (eq x :unspecific)))))
+ (if (or (specificp port)
+ (and (specificp host) (plusp (length host)))
+ (specificp scheme))
+ (let ((prefix ""))
+ (when (specificp port)
+ (setf prefix (format nil ":~D" port)))
+ (when (and (specificp host) (plusp (length host)))
+ (setf prefix (strcat host prefix)))
+ (setf prefix (strcat ":" prefix))
+ (when (specificp scheme)
+ (setf prefix (strcat scheme prefix)))
+ (assert (and directory (eq (first directory) :absolute)))
+ (make-pathname* :directory `(:absolute ,prefix ,@(rest directory))
+ :defaults pathname)))
+ pathname)))
+
+ (defun* (translate-pathname*) (path absolute-source destination &optional root source)
+ (declare (ignore source))
+ (cond
+ ((functionp destination)
+ (funcall destination path absolute-source))
+ ((eq destination t)
+ path)
+ ((not (pathnamep destination))
+ (error "Invalid destination"))
+ ((not (absolute-pathname-p destination))
+ (translate-pathname path absolute-source (merge-pathnames* destination root)))
+ (root
+ (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
+ (t
+ (translate-pathname path absolute-source destination))))
+
+ (defvar *output-translation-function* 'identity
+ "Hook for output translations.
+
+This function needs to be idempotent, so that actions can work
+whether their inputs were translated or not,
+which they will be if we are composing operations. e.g. if some
+create-lisp-op creates a lisp file from some higher-level input,
+you need to still be able to use compile-op on that lisp file."))
+
+;;;; -------------------------------------------------------------------------
+;;;; Portability layer around Common Lisp filesystem access
+
+(uiop/package:define-package :uiop/filesystem
+ (:nicknames :asdf/filesystem)
+ (:recycle :uiop/filesystem :asdf/pathname :asdf)
+ (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname)
+ (:export
+ ;; Native namestrings
+ #:native-namestring #:parse-native-namestring
+ ;; Probing the filesystem
+ #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p
+ #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories
+ #:collect-sub*directories
+ ;; Resolving symlinks somewhat
+ #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlinks*
+ ;; merging with cwd
+ #:get-pathname-defaults #:call-with-current-directory #:with-current-directory
+ ;; Environment pathnames
+ #:inter-directory-separator #:split-native-pathnames-string
+ #:getenv-pathname #:getenv-pathnames
+ #:getenv-absolute-directory #:getenv-absolute-directories
+ #:lisp-implementation-directory #:lisp-implementation-pathname-p
+ ;; Simple filesystem operations
+ #:ensure-all-directories-exist
+ #:rename-file-overwriting-target
+ #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree))
+(in-package :uiop/filesystem)
+
+;;; Native namestrings, as seen by the operating system calls rather than Lisp
+(with-upgradability ()
+ (defun native-namestring (x)
+ "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system"
+ (when x
+ (let ((p (pathname x)))
+ #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978
+ #+(or cmu scl) (ext:unix-namestring p nil)
+ #+sbcl (sb-ext:native-namestring p)
+ #-(or clozure cmu sbcl scl)
+ (if (os-unix-p) (unix-namestring p)
+ (namestring p)))))
+
+ (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
+ "From a native namestring suitable for use by the operating system, return
+a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
+ (check-type string (or string null))
+ (let* ((pathname
+ (when string
+ (with-pathname-defaults ()
+ #+clozure (ccl:native-to-pathname string)
+ #+sbcl (sb-ext:parse-native-namestring string)
+ #-(or clozure sbcl)
+ (if (os-unix-p)
+ (parse-unix-namestring string :ensure-directory ensure-directory)
+ (parse-namestring string)))))
+ (pathname
+ (if ensure-directory
+ (and pathname (ensure-directory-pathname pathname))
+ pathname)))
+ (apply 'ensure-pathname pathname constraints))))
+
+
+;;; Probing the filesystem
+(with-upgradability ()
+ (defun truename* (p)
+ ;; avoids both logical-pathname merging and physical resolution issues
+ (and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil))))
+
+ (defun safe-file-write-date (pathname)
+ ;; If FILE-WRITE-DATE returns NIL, it's possible that
+ ;; the user or some other agent has deleted an input file.
+ ;; Also, generated files will not exist at the time planning is done
+ ;; and calls compute-action-stamp which calls safe-file-write-date.
+ ;; So it is very possible that we can't get a valid file-write-date,
+ ;; and we can survive and we will continue the planning
+ ;; as if the file were very old.
+ ;; (or should we treat the case in a different, special way?)
+ (and pathname
+ (handler-case (file-write-date (translate-logical-pathname pathname))
+ (file-error () nil))))
+
+ (defun probe-file* (p &key truename)
+ "when given a pathname P (designated by a string as per PARSE-NAMESTRING),
+probes the filesystem for a file or directory with given pathname.
+If it exists, return its truename is ENSURE-PATHNAME is true,
+or the original (parsed) pathname if it is false (the default)."
+ (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations
+ (etypecase p
+ (null nil)
+ (string (probe-file* (parse-namestring p) :truename truename))
+ (pathname
+ (and (not (wild-pathname-p p))
+ (handler-case
+ (or
+ #+allegro
+ (probe-file p :follow-symlinks truename)
+ #-(or allegro clisp gcl2.6)
+ (if truename
+ (probe-file p)
+ (ignore-errors
+ (let ((pp (translate-logical-pathname p)))
+ (and
+ #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
+ #+(and lispworks unix) (system:get-file-stat pp)
+ #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
+ #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
+ p))))
+ #+(or clisp gcl2.6)
+ #.(flet ((probe (probe)
+ `(let ((foundtrue ,probe))
+ (cond
+ (truename foundtrue)
+ (foundtrue p)))))
+ #+gcl2.6
+ (probe '(or (probe-file p)
+ (and (directory-pathname-p p)
+ (ignore-errors
+ (ensure-directory-pathname
+ (truename* (subpathname
+ (ensure-directory-pathname p) ".")))))))
+ #+clisp
+ (let* ((fs (find-symbol* '#:file-stat :posix nil))
+ (pp (find-symbol* '#:probe-pathname :ext nil))
+ (resolve (if pp
+ `(ignore-errors (,pp p))
+ '(or (truename* p)
+ (truename* (ignore-errors (ensure-directory-pathname p)))))))
+ (if fs
+ `(if truename
+ ,resolve
+ (and (ignore-errors (,fs p)) p))
+ (probe resolve)))))
+ (file-error () nil)))))))
+
+ (defun directory-exists-p (x)
+ (let ((p (probe-file* x :truename t)))
+ (and (directory-pathname-p p) p)))
+
+ (defun file-exists-p (x)
+ (let ((p (probe-file* x :truename t)))
+ (and (file-pathname-p p) p)))
+
+ (defun directory* (pathname-spec &rest keys &key &allow-other-keys)
+ (apply 'directory pathname-spec
+ (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
+ #+(or clozure digitool) '(:follow-links nil)
+ #+clisp '(:circle t :if-does-not-exist :ignore)
+ #+(or cmu scl) '(:follow-links nil :truenamep nil)
+ #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
+ '(:resolve-symlinks nil))))))
+
+ (defun filter-logical-directory-results (directory entries merger)
+ (if (logical-pathname-p directory)
+ ;; Try hard to not resolve logical-pathname into physical pathnames;
+ ;; otherwise logical-pathname users/lovers will be disappointed.
+ ;; If directory* could use some implementation-dependent magic,
+ ;; we will have logical pathnames already; otherwise,
+ ;; we only keep pathnames for which specifying the name and
+ ;; translating the LPN commute.
+ (loop :for f :in entries
+ :for p = (or (and (logical-pathname-p f) f)
+ (let* ((u (ignore-errors (funcall merger f))))
+ ;; The first u avoids a cumbersome (truename u) error.
+ ;; At this point f should already be a truename,
+ ;; but isn't quite in CLISP, for it doesn't have :version :newest
+ (and u (equal (truename* u) (truename* f)) u)))
+ :when p :collect p)
+ entries))
+
+ (defun directory-files (directory &optional (pattern *wild-file*))
+ (let ((dir (pathname directory)))
+ (when (logical-pathname-p dir)
+ ;; Because of the filtering we do below,
+ ;; logical pathnames have restrictions on wild patterns.
+ ;; Not that the results are very portable when you use these patterns on physical pathnames.
+ (when (wild-pathname-p dir)
+ (error "Invalid wild pattern in logical directory ~S" directory))
+ (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
+ (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
+ (setf pattern (make-pathname-logical pattern (pathname-host dir))))
+ (let* ((pat (merge-pathnames* pattern dir))
+ (entries (append (ignore-errors (directory* pat))
+ #+clisp
+ (when (equal :wild (pathname-type pattern))
+ (ignore-errors (directory* (make-pathname :type nil :defaults pat)))))))
+ (filter-logical-directory-results
+ directory entries
+ #'(lambda (f)
+ (make-pathname :defaults dir
+ :name (make-pathname-component-logical (pathname-name f))
+ :type (make-pathname-component-logical (pathname-type f))
+ :version (make-pathname-component-logical (pathname-version f))))))))
+
+ (defun subdirectories (directory)
+ (let* ((directory (ensure-directory-pathname directory))
+ #-(or abcl cormanlisp genera xcl)
+ (wild (merge-pathnames*
+ #-(or abcl allegro cmu lispworks sbcl scl xcl)
+ *wild-directory*
+ #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
+ directory))
+ (dirs
+ #-(or abcl cormanlisp genera xcl)
+ (ignore-errors
+ (directory* wild . #.(or #+clozure '(:directories t :files nil)
+ #+mcl '(:directories t))))
+ #+(or abcl xcl) (system:list-directory directory)
+ #+cormanlisp (cl::directory-subdirs directory)
+ #+genera (fs:directory-list directory))
+ #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
+ (dirs (loop :for x :in dirs
+ :for d = #+(or abcl xcl) (extensions:probe-directory x)
+ #+allegro (excl:probe-directory x)
+ #+(or cmu sbcl scl) (directory-pathname-p x)
+ #+genera (getf (cdr x) :directory)
+ #+lispworks (lw:file-directory-p x)
+ :when d :collect #+(or abcl allegro xcl) d
+ #+genera (ensure-directory-pathname (first x))
+ #+(or cmu lispworks sbcl scl) x)))
+ (filter-logical-directory-results
+ directory dirs
+ (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
+ '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
+ #'(lambda (d)
+ (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
+ (and (consp dir) (consp (cdr dir))
+ (make-pathname
+ :defaults directory :name nil :type nil :version nil
+ :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
+
+ (defun collect-sub*directories (directory collectp recursep collector)
+ (when (call-function collectp directory)
+ (call-function collector directory))
+ (dolist (subdir (subdirectories directory))
+ (when (call-function recursep subdir)
+ (collect-sub*directories subdir collectp recursep collector)))))
+
+;;; Resolving symlinks somewhat
+(with-upgradability ()
+ (defun truenamize (pathname)
+ "Resolve as much of a pathname as possible"
+ (block nil
+ (when (typep pathname '(or null logical-pathname)) (return pathname))
+ (let ((p pathname))
+ (unless (absolute-pathname-p p)
+ (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil))
+ (return p))))
+ (when (logical-pathname-p p) (return p))
+ (let ((found (probe-file* p :truename t)))
+ (when found (return found)))
+ (let* ((directory (normalize-pathname-directory-component (pathname-directory p)))
+ (up-components (reverse (rest directory)))
+ (down-components ()))
+ (assert (eq :absolute (first directory)))
+ (loop :while up-components :do
+ (if-let (parent (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components))
+ :name nil :type nil :version nil :defaults p)))
+ (return (merge-pathnames* (make-pathname* :directory `(:relative ,@down-components)
+ :defaults p)
+ (ensure-directory-pathname parent)))
+ (push (pop up-components) down-components))
+ :finally (return p))))))
+
+ (defun resolve-symlinks (path)
+ #-allegro (truenamize path)
+ #+allegro
+ (if (physical-pathname-p path)
+ (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path)
+ path))
+
+ (defvar *resolve-symlinks* t
+ "Determine whether or not ASDF resolves symlinks when defining systems.
+Defaults to T.")
+
+ (defun resolve-symlinks* (path)
+ (if *resolve-symlinks*
+ (and path (resolve-symlinks path))
+ path)))
+
+
+;;; Check pathname constraints
+(with-upgradability ()
+ (defun ensure-pathname
+ (pathname &key
+ on-error
+ defaults type dot-dot
+ want-pathname
+ want-logical want-physical ensure-physical
+ want-relative want-absolute ensure-absolute ensure-subpath
+ want-non-wild want-wild wilden
+ want-file want-directory ensure-directory
+ want-existing ensure-directories-exist
+ truename resolve-symlinks truenamize
+ &aux (p pathname)) ;; mutable working copy, preserve original
+ "Coerces its argument into a PATHNAME,
+optionally doing some transformations and checking specified constraints.
+
+If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
+
+If the argument is a STRING, it is first converted to a pathname via PARSE-UNIX-NAMESTRING
+reusing the keywords DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE;
+then the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true,
+and the all the checks and transformations are run.
+
+Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
+The boolean T is an alias for ERROR.
+ERROR means that an error will be raised if the constraint is not satisfied.
+CERROR means that an continuable error will be raised if the constraint is not satisfied.
+IGNORE means just return NIL instead of the pathname.
+
+The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION)
+that will be called with the the following arguments:
+a generic format string for ensure pathname, the pathname,
+the keyword argument corresponding to the failed check or transformation,
+a format string for the reason ENSURE-PATHNAME failed,
+and a list with arguments to that format string.
+If ON-ERROR is NIL, ERROR is used instead, which does the right thing.
+You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
+
+The transformations and constraint checks are done in this order,
+which is also the order in the lambda-list:
+
+WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
+Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
+WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
+WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME
+ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME
+WANT-RELATIVE checks that pathname has a relative directory component
+WANT-ABSOLUTE checks that pathname does have an absolute directory component
+ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again
+that the result absolute is an absolute pathname indeed.
+ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS.
+WANT-FILE checks that pathname has a non-nil FILE component
+WANT-DIRECTORY checks that pathname has nil FILE and TYPE components
+ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret
+any file and type components as being actually a last directory component.
+WANT-NON-WILD checks that pathname is not a wild pathname
+WANT-WILD checks that pathname is a wild pathname
+WILDEN merges the pathname with **/*.*.* if it is not wild
+WANT-EXISTING checks that a file (or directory) exists with that pathname.
+ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST.
+TRUENAME replaces the pathname by its truename, or errors if not possible.
+RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS.
+TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
+ (block nil
+ (flet ((report-error (keyword description &rest arguments)
+ (call-function (or on-error 'error)
+ "Invalid pathname ~S: ~*~?"
+ pathname keyword description arguments)))
+ (macrolet ((err (constraint &rest arguments)
+ `(report-error ',(intern* constraint :keyword) ,@arguments))
+ (check (constraint condition &rest arguments)
+ `(when ,constraint
+ (unless ,condition (err ,constraint ,@arguments))))
+ (transform (transform condition expr)
+ `(when ,transform
+ (,@(if condition `(when ,condition) '(progn))
+ (setf p ,expr)))))
+ (etypecase p
+ ((or null pathname))
+ (string
+ (setf p (parse-unix-namestring
+ p :defaults defaults :type type :dot-dot dot-dot
+ :ensure-directory ensure-directory :want-relative want-relative))))
+ (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
+ (unless (pathnamep p) (return nil))
+ (check want-logical (logical-pathname-p p) "Expected a logical pathname")
+ (check want-physical (physical-pathname-p p) "Expected a physical pathname")
+ (transform ensure-physical () (translate-logical-pathname p))
+ (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
+ (check want-relative (relative-pathname-p p) "Expected a relative pathname")
+ (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
+ (transform ensure-absolute (not (absolute-pathname-p p))
+ (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?")))
+ (check ensure-absolute (absolute-pathname-p p)
+ "Could not make into an absolute pathname even after merging with ~S" defaults)
+ (check ensure-subpath (absolute-pathname-p defaults)
+ "cannot be checked to be a subpath of non-absolute pathname ~S" defaults)
+ (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults)
+ (check want-file (file-pathname-p p) "Expected a file pathname")
+ (check want-directory (directory-pathname-p p) "Expected a directory pathname")
+ (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p))
+ (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname")
+ (check want-wild (wild-pathname-p p) "Expected a wildcard pathname")
+ (transform wilden (not (wild-pathname-p p)) (wilden p))
+ (when want-existing
+ (let ((existing (probe-file* p :truename truename)))
+ (if existing
+ (when truename
+ (return existing))
+ (err want-existing "Expected an existing pathname"))))
+ (when ensure-directories-exist (ensure-directories-exist p))
+ (when truename
+ (let ((truename (truename* p)))
+ (if truename
+ (return truename)
+ (err truename "Can't get a truename for pathname"))))
+ (transform resolve-symlinks () (resolve-symlinks p))
+ (transform truenamize () (truenamize p))
+ p)))))
+
+
+;;; Pathname defaults
+(with-upgradability ()
+ (defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*))
+ (or (absolute-pathname-p defaults)
+ (merge-pathnames* defaults (getcwd))))
+
+ (defun call-with-current-directory (dir thunk)
+ (if dir
+ (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir))))
+ (*default-pathname-defaults* dir)
+ (cwd (getcwd)))
+ (chdir dir)
+ (unwind-protect
+ (funcall thunk)
+ (chdir cwd)))
+ (funcall thunk)))
+
+ (defmacro with-current-directory ((&optional dir) &body body)
+ "Call BODY while the POSIX current working directory is set to DIR"
+ `(call-with-current-directory ,dir #'(lambda () ,@body))))
+
+
+;;; Environment pathnames
+(with-upgradability ()
+ (defun inter-directory-separator ()
+ (if (os-unix-p) #\: #\;))
+
+ (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
+ (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
+ :collect (apply 'parse-native-namestring namestring constraints)))
+
+ (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys)
+ ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory
+ (apply 'parse-native-namestring (getenvp x)
+ :ensure-directory (or ensure-directory want-directory)
+ :on-error (or on-error
+ `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
+ constraints))
+ (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
+ (apply 'split-native-pathnames-string (getenvp x)
+ :on-error (or on-error
+ `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
+ constraints))
+ (defun getenv-absolute-directory (x)
+ (getenv-pathname x :want-absolute t :ensure-directory t))
+ (defun getenv-absolute-directories (x)
+ (getenv-pathnames x :want-absolute t :ensure-directory t))
+
+ (defun lisp-implementation-directory (&key truename)
+ (declare (ignorable truename))
+ #+(or clozure ecl gcl mkcl sbcl)
+ (let ((dir
+ (ignore-errors
+ #+clozure #p"ccl:"
+ #+(or ecl mkcl) #p"SYS:"
+ #+gcl system::*system-directory*
+ #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
+ (funcall it)
+ (getenv-pathname "SBCL_HOME" :ensure-directory t)))))
+ (if (and dir truename)
+ (truename* dir)
+ dir)))
+
+ (defun lisp-implementation-pathname-p (pathname)
+ ;; Other builtin systems are those under the implementation directory
+ (and (when pathname
+ (if-let (impdir (lisp-implementation-directory))
+ (or (subpathp pathname impdir)
+ (when *resolve-symlinks*
+ (if-let (truename (truename* pathname))
+ (if-let (trueimpdir (truename* impdir))
+ (subpathp truename trueimpdir)))))))