+;;;; -------------------------------------------------------------------------
+;;;; 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)))))))
+ t)))
+
+
+;;; Simple filesystem operations
+(with-upgradability ()
+ (defun ensure-all-directories-exist (pathnames)
+ (dolist (pathname pathnames)
+ (when pathname
+ (ensure-directories-exist (translate-logical-pathname pathname)))))
+
+ (defun rename-file-overwriting-target (source target)
+ #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic
+ (posix:copy-file source target :method :rename)
+ #-clisp
+ (rename-file source target
+ #+clozure :if-exists #+clozure :rename-and-delete))
+
+ (defun delete-file-if-exists (x)
+ (when x (handler-case (delete-file x) (file-error () nil))))
+
+ (defun delete-empty-directory (directory-pathname)
+ "Delete an empty directory"
+ #+(or abcl digitool gcl) (delete-file directory-pathname)
+ #+allegro (excl:delete-directory directory-pathname)
+ #+clisp (ext:delete-directory directory-pathname)
+ #+clozure (ccl::delete-empty-directory directory-pathname)
+ #+(or cmu scl) (multiple-value-bind (ok errno)
+ (unix:unix-rmdir (native-namestring directory-pathname))
+ (unless ok
+ #+cmu (error "Error number ~A when trying to delete directory ~A"
+ errno directory-pathname)
+ #+scl (error "~@<Error deleting ~S: ~A~@:>"
+ directory-pathname (unix:get-unix-error-msg errno))))
+ #+cormanlisp (win32:delete-directory directory-pathname)
+ #+ecl (si:rmdir directory-pathname)
+ #+lispworks (lw:delete-directory directory-pathname)
+ #+mkcl (mkcl:rmdir directory-pathname)
+ #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
+ `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
+ `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
+ #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks sbcl scl)
+ (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera xcl
+
+ (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
+ "Delete a directory including all its recursive contents, aka rm -rf.
+
+To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be
+a physical non-wildcard directory pathname (not namestring).
+
+If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens:
+if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done.
+
+Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass
+the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument
+which in practice is thus compulsory, and validates by returning a non-NIL result.
+If you're suicidal or extremely confident, just use :VALIDATE T."
+ (check-type if-does-not-exist (member :error :ignore))
+ (cond
+ ((not (and (pathnamep directory-pathname) (directory-pathname-p directory-pathname)
+ (physical-pathname-p directory-pathname) (not (wild-pathname-p directory-pathname))))
+ (error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname"
+ 'delete-filesystem-tree directory-pathname))
+ ((not validatep)
+ (error "~S was asked to delete ~S but was not provided a validation predicate"
+ 'delete-filesystem-tree directory-pathname))
+ ((not (call-function validate directory-pathname))
+ (error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
+ 'delete-filesystem-tree directory-pathname validate))
+ ((not (directory-exists-p directory-pathname))
+ (ecase if-does-not-exist
+ (:error
+ (error "~S was asked to delete ~S but the directory does not exist"
+ 'delete-filesystem-tree directory-pathname))
+ (:ignore nil)))
+ #-(or allegro cmu clozure sbcl scl)
+ ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
+ ;; except on implementations where we can prevent DIRECTORY from following symlinks;
+ ;; instead spawn a standard external program to do the dirty work.
+ (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname))))
+ (t
+ ;; On supported implementation, call supported system functions
+ #+allegro (symbol-call :excl.osi :delete-directory-and-files
+ directory-pathname :if-does-not-exist if-does-not-exist)
+ #+clozure (ccl:delete-directory directory-pathname)
+ #+genera (error "~S not implemented on ~S" 'delete-directory-tree (implementation-type))
+ #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
+ `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later
+ '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree))
+ ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks,
+ ;; do things the hard way.
+ #-(or allegro clozure genera sbcl)
+ (let ((sub*directories
+ (while-collecting (c)
+ (collect-sub*directories directory-pathname t t #'c))))
+ (dolist (d (nreverse sub*directories))
+ (map () 'delete-file (directory-files d))
+ (delete-empty-directory d)))))))
+
+;;;; ---------------------------------------------------------------------------
+;;;; Utilities related to streams
+
+(uiop/package:define-package :uiop/stream
+ (:nicknames :asdf/stream)
+ (:recycle :uiop/stream :asdf/stream :asdf)
+ (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem)
+ (:export
+ #:*default-stream-element-type* #:*stderr* #:setup-stderr
+ #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
+ #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
+ #:*default-encoding* #:*utf-8-external-format*
+ #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string
+ #:with-output #:output-string #:with-input
+ #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file
+ #:finish-outputs #:format! #:safe-format!
+ #:copy-stream-to-stream #:concatenate-files #:copy-file
+ #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
+ #:slurp-stream-forms #:slurp-stream-form
+ #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form
+ #:eval-input #:eval-thunk #:standard-eval-thunk
+ ;; Temporary files
+ #:*temporary-directory* #:temporary-directory #:default-temporary-directory
+ #:setup-temporary-directory
+ #:call-with-temporary-file #:with-temporary-file
+ #:add-pathname-suffix #:tmpize-pathname
+ #:call-with-staging-pathname #:with-staging-pathname))
+(in-package :uiop/stream)
+
+(with-upgradability ()
+ (defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default)
+ "default element-type for open (depends on the current CL implementation)")
+
+ (defvar *stderr* *error-output*
+ "the original error output stream at startup")
+
+ (defun setup-stderr ()
+ (setf *stderr*
+ #+allegro excl::*stderr*
+ #+clozure ccl::*stderr*
+ #-(or allegro clozure) *error-output*))
+ (setup-stderr))
+
+
+;;; Encodings (mostly hooks only; full support requires asdf-encodings)
+(with-upgradability ()
+ (defparameter *default-encoding*
+ ;; preserve explicit user changes to something other than the legacy default :default
+ (or (if-let (previous (and (boundp '*default-encoding*) (symbol-value '*default-encoding*)))
+ (unless (eq previous :default) previous))
+ :utf-8)
+ "Default encoding for source files.
+The default value :utf-8 is the portable thing.
+The legacy behavior was :default.
+If you (asdf:load-system :asdf-encodings) then
+you will have autodetection via *encoding-detection-hook* below,
+reading emacs-style -*- coding: utf-8 -*- specifications,
+and falling back to utf-8 or latin1 if nothing is specified.")
+
+ (defparameter *utf-8-external-format*
+ #+(and asdf-unicode (not clisp)) :utf-8
+ #+(and asdf-unicode clisp) charset:utf-8
+ #-asdf-unicode :default
+ "Default :external-format argument to pass to CL:OPEN and also
+CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
+On modern implementations, this will decode UTF-8 code points as CL characters.
+On legacy implementations, it may fall back on some 8-bit encoding,
+with non-ASCII code points being read as several CL characters;
+hopefully, if done consistently, that won't affect program behavior too much.")
+
+ (defun always-default-encoding (pathname)
+ (declare (ignore pathname))
+ *default-encoding*)
+
+ (defvar *encoding-detection-hook* #'always-default-encoding
+ "Hook for an extension to define a function to automatically detect a file's encoding")
+
+ (defun detect-encoding (pathname)
+ (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname))
+ (funcall *encoding-detection-hook* pathname)
+ *default-encoding*))
+
+ (defun default-encoding-external-format (encoding)
+ (case encoding
+ (:default :default) ;; for backward-compatibility only. Explicit usage discouraged.
+ (:utf-8 *utf-8-external-format*)
+ (otherwise
+ (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
+ :default)))
+
+ (defvar *encoding-external-format-hook*
+ #'default-encoding-external-format
+ "Hook for an extension to define a mapping between non-default encodings
+and implementation-defined external-format's")
+
+ (defun encoding-external-format (encoding)
+ (funcall *encoding-external-format-hook* (or encoding *default-encoding*))))
+
+
+;;; Safe syntax
+(with-upgradability ()
+ (defvar *standard-readtable* (copy-readtable nil))
+
+ (defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
+ "Establish safe CL reader options around the evaluation of BODY"
+ `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body))))
+
+ (defun call-with-safe-io-syntax (thunk &key (package :cl))
+ (with-standard-io-syntax
+ (let ((*package* (find-package package))
+ (*read-default-float-format* 'double-float)
+ (*print-readably* nil)
+ (*read-eval* nil))
+ (funcall thunk))))
+
+ (defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace)
+ (with-safe-io-syntax (:package package)
+ (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace))))
+
+
+;;; Output to a stream or string, FORMAT-style
+(with-upgradability ()
+ (defun call-with-output (output function)
+ "Calls FUNCTION with an actual stream argument,
+behaving like FORMAT with respect to how stream designators are interpreted:
+If OUTPUT is a stream, use it as the stream.
+If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
+If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
+If OUTPUT is a string with a fill-pointer, use it as a string-output-stream.
+Otherwise, signal an error."
+ (etypecase output
+ (null
+ (with-output-to-string (stream) (funcall function stream)))
+ ((eql t)
+ (funcall function *standard-output*))
+ (stream
+ (funcall function output))
+ (string
+ (assert (fill-pointer output))
+ (with-output-to-string (stream output) (funcall function stream)))))
+
+ (defmacro with-output ((output-var &optional (value output-var)) &body body)
+ "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR)
+as per FORMAT, and evaluate BODY within the scope of this binding."
+ `(call-with-output ,value #'(lambda (,output-var) ,@body)))
+
+ (defun output-string (string &optional output)
+ "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
+ (if output
+ (with-output (output) (princ string output))
+ string)))
+
+
+;;; Input helpers
+(with-upgradability ()
+ (defun call-with-input (input function)
+ "Calls FUNCTION with an actual stream argument, interpreting
+stream designators like READ, but also coercing strings to STRING-INPUT-STREAM.
+If INPUT is a STREAM, use it as the stream.
+If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
+If INPUT is T, use *TERMINAL-IO* as the stream.
+As an extension, if INPUT is a string, use it as a string-input-stream.
+Otherwise, signal an error."
+ (etypecase input
+ (null (funcall function *standard-input*))
+ ((eql t) (funcall function *terminal-io*))
+ (stream (funcall function input))
+ (string (with-input-from-string (stream input) (funcall function stream)))))
+
+ (defmacro with-input ((input-var &optional (value input-var)) &body body)
+ "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
+as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
+ `(call-with-input ,value #'(lambda (,input-var) ,@body)))
+
+ (defun call-with-input-file (pathname thunk
+ &key
+ (element-type *default-stream-element-type*)
+ (external-format *utf-8-external-format*)
+ (if-does-not-exist :error))
+ "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
+Other keys are accepted but discarded."
+ #+gcl2.6 (declare (ignore external-format))
+ (with-open-file (s pathname :direction :input
+ :element-type element-type
+ #-gcl2.6 :external-format #-gcl2.6 external-format
+ :if-does-not-exist if-does-not-exist)
+ (funcall thunk s)))
+
+ (defmacro with-input-file ((var pathname &rest keys
+ &key element-type external-format if-does-not-exist)
+ &body body)
+ (declare (ignore element-type external-format if-does-not-exist))
+ `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))
+
+ (defun call-with-output-file (pathname thunk
+ &key
+ (element-type *default-stream-element-type*)
+ (external-format *utf-8-external-format*)
+ (if-exists :error)
+ (if-does-not-exist :create))
+ "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
+Other keys are accepted but discarded."
+ #+gcl2.6 (declare (ignore external-format))
+ (with-open-file (s pathname :direction :output
+ :element-type element-type
+ #-gcl2.6 :external-format #-gcl2.6 external-format
+ :if-exists if-exists
+ :if-does-not-exist if-does-not-exist)
+ (funcall thunk s)))
+
+ (defmacro with-output-file ((var pathname &rest keys
+ &key element-type external-format if-exists if-does-not-exist)
+ &body body)
+ (declare (ignore element-type external-format if-exists if-does-not-exist))
+ `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys)))
+
+;;; Ensure output buffers are flushed
+(with-upgradability ()
+ (defun finish-outputs (&rest streams)
+ "Finish output on the main output streams as well as any specified one.
+Useful for portably flushing I/O before user input or program exit."
+ ;; CCL notably buffers its stream output by default.
+ (dolist (s (append streams
+ (list *stderr* *error-output* *standard-output* *trace-output*
+ *debug-io* *terminal-io* *debug-io* *query-io*)))
+ (ignore-errors (finish-output s)))
+ (values))
+
+ (defun format! (stream format &rest args)
+ "Just like format, but call finish-outputs before and after the output."
+ (finish-outputs stream)
+ (apply 'format stream format args)
+ (finish-output stream))
+
+ (defun safe-format! (stream format &rest args)
+ (with-safe-io-syntax ()
+ (ignore-errors (apply 'format! stream format args))
+ (finish-outputs stream)))) ; just in case format failed
+
+
+;;; Simple Whole-Stream processing
+(with-upgradability ()
+ (defun copy-stream-to-stream (input output &key element-type buffer-size linewise prefix)
+ "Copy the contents of the INPUT stream into the OUTPUT stream.
+If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX.
+Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
+ (with-open-stream (input input)
+ (if linewise
+ (loop* :for (line eof) = (multiple-value-list (read-line input nil nil))
+ :while line :do
+ (when prefix (princ prefix output))
+ (princ line output)
+ (unless eof (terpri output))
+ (finish-output output)
+ (when eof (return)))
+ (loop
+ :with buffer-size = (or buffer-size 8192)
+ :for buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
+ :for end = (read-sequence buffer input)
+ :until (zerop end)
+ :do (write-sequence buffer output :end end)
+ (when (< end buffer-size) (return))))))
+
+ (defun concatenate-files (inputs output)
+ (with-open-file (o output :element-type '(unsigned-byte 8)
+ :direction :output :if-exists :rename-and-delete)
+ (dolist (input inputs)
+ (with-open-file (i input :element-type '(unsigned-byte 8)
+ :direction :input :if-does-not-exist :error)
+ (copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
+
+ (defun copy-file (input output)
+ ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
+ (concatenate-files (list input) output))
+
+ (defun slurp-stream-string (input &key (element-type 'character))
+ "Read the contents of the INPUT stream as a string"
+ (with-open-stream (input input)
+ (with-output-to-string (output)
+ (copy-stream-to-stream input output :element-type element-type))))
+
+ (defun slurp-stream-lines (input &key count)
+ "Read the contents of the INPUT stream as a list of lines, return those lines.
+
+Read no more than COUNT lines."
+ (check-type count (or null integer))
+ (with-open-stream (input input)
+ (loop :for n :from 0
+ :for l = (and (or (not count) (< n count))
+ (read-line input nil nil))
+ :while l :collect l)))
+
+ (defun slurp-stream-line (input &key (at 0))
+ "Read the contents of the INPUT stream as a list of lines,
+then return the ACCESS-AT of that list of lines using the AT specifier.
+PATH defaults to 0, i.e. return the first line.
+PATH is typically an integer, or a list of an integer and a function.
+If PATH is NIL, it will return all the lines in the file.
+
+The stream will not be read beyond the Nth lines,
+where N is the index specified by path
+if path is either an integer or a list that starts with an integer."
+ (access-at (slurp-stream-lines input :count (access-at-count at)) at))
+
+ (defun slurp-stream-forms (input &key count)
+ "Read the contents of the INPUT stream as a list of forms,
+and return those forms.
+
+If COUNT is null, read to the end of the stream;
+if COUNT is an integer, stop after COUNT forms were read.
+
+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
+ (check-type count (or null integer))
+ (loop :with eof = '#:eof
+ :for n :from 0
+ :for form = (if (and count (>= n count))
+ eof
+ (read-preserving-whitespace input nil eof))
+ :until (eq form eof) :collect form))
+
+ (defun slurp-stream-form (input &key (at 0))
+ "Read the contents of the INPUT stream as a list of forms,
+then return the ACCESS-AT of these forms following the AT.
+AT defaults to 0, i.e. return the first form.
+AT is typically a list of integers.
+If AT is NIL, it will return all the forms in the file.
+
+The stream will not be read beyond the Nth form,
+where N is the index specified by path,
+if path is either an integer or a list that starts with an integer.
+
+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
+ (access-at (slurp-stream-forms input :count (access-at-count at)) at))
+
+ (defun read-file-string (file &rest keys)
+ "Open FILE with option KEYS, read its contents as a string"
+ (apply 'call-with-input-file file 'slurp-stream-string keys))
+
+ (defun read-file-lines (file &rest keys)
+ "Open FILE with option KEYS, read its contents as a list of lines
+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
+ (apply 'call-with-input-file file 'slurp-stream-lines keys))
+
+ (defun read-file-forms (file &rest keys &key count &allow-other-keys)
+ "Open input FILE with option KEYS (except COUNT),
+and read its contents as per SLURP-STREAM-FORMS with given COUNT.
+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
+ (apply 'call-with-input-file file
+ #'(lambda (input) (slurp-stream-forms input :count count))
+ (remove-plist-key :count keys)))
+
+ (defun read-file-form (file &rest keys &key (at 0) &allow-other-keys)
+ "Open input FILE with option KEYS (except AT),
+and read its contents as per SLURP-STREAM-FORM with given AT specifier.
+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
+ (apply 'call-with-input-file file
+ #'(lambda (input) (slurp-stream-form input :at at))
+ (remove-plist-key :at keys)))
+
+ (defun safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys)
+ "Reads the specified form from the top of a file using a safe standardized syntax.
+Extracts the form using READ-FILE-FORM,
+within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
+ (with-safe-io-syntax (:package package)
+ (apply 'read-file-form pathname (remove-plist-key :package keys))))
+
+ (defun eval-input (input)
+ "Portably read and evaluate forms from INPUT, return the last values."
+ (with-input (input)
+ (loop :with results :with eof ='#:eof
+ :for form = (read input nil eof)
+ :until (eq form eof)
+ :do (setf results (multiple-value-list (eval form)))
+ :finally (return (apply 'values results)))))
+
+ (defun eval-thunk (thunk)
+ "Evaluate a THUNK of code:
+If a function, FUNCALL it without arguments.
+If a constant literal and not a sequence, return it.
+If a cons or a symbol, EVAL it.
+If a string, repeatedly read and evaluate from it, returning the last values."
+ (etypecase thunk
+ ((or boolean keyword number character pathname) thunk)
+ ((or cons symbol) (eval thunk))
+ (function (funcall thunk))
+ (string (eval-input thunk))))
+
+ (defun standard-eval-thunk (thunk &key (package :cl))
+ "Like EVAL-THUNK, but in a more standardized evaluation context."
+ ;; Note: it's "standard-" not "safe-", because evaluation is never safe.
+ (when thunk
+ (with-safe-io-syntax (:package package)
+ (let ((*read-eval* t))
+ (eval-thunk thunk))))))
+
+
+;;; Using temporary files
+(with-upgradability ()
+ (defun default-temporary-directory ()
+ (or
+ (when (os-unix-p)
+ (or (getenv-pathname "TMPDIR" :ensure-directory t)
+ (parse-native-namestring "/tmp/")))
+ (when (os-windows-p)
+ (getenv-pathname "TEMP" :ensure-directory t))
+ (subpathname (user-homedir-pathname) "tmp/")))
+
+ (defvar *temporary-directory* nil)
+
+ (defun temporary-directory ()
+ (or *temporary-directory* (default-temporary-directory)))
+
+ (defun setup-temporary-directory ()
+ (setf *temporary-directory* (default-temporary-directory))
+ ;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1
+ #+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*))
+
+ (defun call-with-temporary-file
+ (thunk &key
+ prefix keep (direction :io)
+ (element-type *default-stream-element-type*)
+ (external-format :default))
+ #+gcl2.6 (declare (ignorable external-format))
+ (check-type direction (member :output :io))
+ (loop
+ :with prefix = (namestring (ensure-absolute-pathname (or prefix "tmp") #'temporary-directory))
+ :for counter :from (random (ash 1 32))
+ :for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
+ ;; TODO: on Unix, do something about umask
+ ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
+ ;; TODO: on Unix, use CFFI and mkstemp -- but asdf/driver is precisely meant to not depend on CFFI or on anything! Grrrr.
+ (with-open-file (stream pathname
+ :direction direction
+ :element-type element-type
+ #-gcl2.6 :external-format #-gcl2.6 external-format
+ :if-exists nil :if-does-not-exist :create)
+ (when stream
+ (return
+ (if keep
+ (funcall thunk stream pathname)
+ (unwind-protect
+ (funcall thunk stream pathname)
+ (ignore-errors (delete-file pathname)))))))))
+
+ (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
+ (pathname (gensym "PATHNAME") pathnamep)
+ prefix keep direction element-type external-format)
+ &body body)
+ "Evaluate BODY where the symbols specified by keyword arguments
+STREAM and PATHNAME are bound corresponding to a newly created temporary file
+ready for I/O. Unless KEEP is specified, delete the file afterwards."
+ (check-type stream symbol)
+ (check-type pathname symbol)
+ `(flet ((think (,stream ,pathname)
+ ,@(unless pathnamep `((declare (ignore ,pathname))))
+ ,@(unless streamp `((when ,stream (close ,stream))))
+ ,@body))
+ #-gcl (declare (dynamic-extent #'think))
+ (call-with-temporary-file
+ #'think
+ ,@(when direction `(:direction ,direction))
+ ,@(when prefix `(:prefix ,prefix))
+ ,@(when keep `(:keep ,keep))
+ ,@(when element-type `(:element-type ,element-type))
+ ,@(when external-format `(:external-format external-format)))))
+
+ ;; Temporary pathnames in simple cases where no contention is assumed
+ (defun add-pathname-suffix (pathname suffix)
+ (make-pathname :name (strcat (pathname-name pathname) suffix)
+ :defaults pathname))
+
+ (defun tmpize-pathname (x)
+ (add-pathname-suffix x "-ASDF-TMP"))
+
+ (defun call-with-staging-pathname (pathname fun)
+ "Calls fun with a staging pathname, and atomically
+renames the staging pathname to the pathname in the end.
+Note: this protects only against failure of the program,
+not against concurrent attempts.
+For the latter case, we ought pick random suffix and atomically open it."
+ (let* ((pathname (pathname pathname))
+ (staging (tmpize-pathname pathname)))
+ (unwind-protect
+ (multiple-value-prog1
+ (funcall fun staging)
+ (rename-file-overwriting-target staging pathname))
+ (delete-file-if-exists staging))))