From e6f50e36ad066a5689713584d900e7e9a9ad19f8 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Sat, 16 Mar 2013 20:42:59 -0400
Subject: [PATCH] 2.32.12: UIOP improvements

* delete-empty-directory, delete-directory-tree, directory-exists-p, file-exists-p, copy-file
* fix directory-files on clisp for files with type NIL
* tests: fix assert-pathname-equal, assert-pathnames-equal, bad trace
---
 asdf.asd                            |   2 +-
 bin/asdf-builder                    |   2 +-
 bundle.lisp                         |   2 +
 header.lisp                         |   4 +-
 test/script-support.lisp            |  27 ++++----
 test/test-concatenate-source.script |   8 +--
 test/test-utilities.script          |  30 ++++++--
 uiop/filesystem.lisp                | 103 +++++++++++++++++++++++++---
 uiop/lisp-build.lisp                |   5 +-
 uiop/stream.lisp                    |   6 +-
 uiop/uiop.asd                       |   7 +-
 upgrade.lisp                        |   2 +-
 version.lisp-expr                   |   2 +-
 13 files changed, 159 insertions(+), 41 deletions(-)

diff --git a/asdf.asd b/asdf.asd
index b531b2568..c5e9b9fd1 100644
--- a/asdf.asd
+++ b/asdf.asd
@@ -74,7 +74,7 @@
   :licence "MIT"
   :description "Another System Definition Facility"
   :long-description "ASDF builds Common Lisp software organized into defined systems."
-  :version "2.32.11" ;; to be automatically updated by make bump-version
+  :version "2.32.12" ;; to be automatically updated by make bump-version
   :depends-on ()
   #+asdf3 :encoding #+asdf3 :utf-8
   ;; For most purposes, asdf itself specially counts as a builtin system.
diff --git a/bin/asdf-builder b/bin/asdf-builder
index f2cd43c89..55c804c4b 100755
--- a/bin/asdf-builder
+++ b/bin/asdf-builder
@@ -108,7 +108,7 @@
                  /base/ /files/ /destination/) :show t)
     (run (format nil "tar zcfC ~S ~S ~S/"
                  /tarball/ /build-dir/ name) :show t)
-    (run `("rm" "-rf" ,/destination/) :show t)
+    (delete-directory-tree destination :validate (lambda (x) (equal (native-namestring x) /destination/)))
     (values)))
 
 (defun driver-files ()
diff --git a/bundle.lisp b/bundle.lisp
index d811530b2..104f35402 100644
--- a/bundle.lisp
+++ b/bundle.lisp
@@ -244,6 +244,8 @@
       (call-next-method)))
 
   (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
+    ;; This file selects output files from direct dependencies;
+    ;; your component-depends-on method better gathered the correct dependencies in the correct order.
     (while-collecting (collect)
       (map-direct-dependencies
        o c #'(lambda (sub-o sub-c)
diff --git a/header.lisp b/header.lisp
index 9a892baaf..91d8a90e6 100644
--- a/header.lisp
+++ b/header.lisp
@@ -1,5 +1,5 @@
 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.32.11: Another System Definition Facility.
+;;; This is ASDF 2.32.12: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
@@ -71,7 +71,7 @@
            (existing-version-number (and existing-version (read-from-string existing-major-minor)))
            (away (format nil "~A-~A" :asdf existing-version)))
       (when (and existing-version (< existing-version-number
-                                     (or #+abcl 2.25 #+cmu 2.018 2.27)))
+                                     (or #+abcl 2.25 #+cmu 2.018 #-(or abcl cmu) 2.27)))
         (rename-package :asdf away)
         (when *load-verbose*
           (format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))))
diff --git a/test/script-support.lisp b/test/script-support.lisp
index 089178d7c..7d0abcf67 100644
--- a/test/script-support.lisp
+++ b/test/script-support.lisp
@@ -122,20 +122,25 @@ Some constraints:
     ((equal x y)
      (format t "~S and ~S both evaluate to same path:~%  ~S~%" qx qy x))
     ((acall :pathname-equal x y)
-     (format t "These two expressions yield pathname-equal yet not equal path~%  ~S~%" x)
-     (format t "the first expression ~S yields this:~%  ~S~%" qx (pathname-components x))
-     (format t "the other expression ~S yields that:~%  ~S~%" qy (pathname-components y)))
+     (warn "These two expressions yield pathname-equal yet not equal path~%~
+	the first expression ~S yields this:~%  ~S~%  ~S~%
+	the other expression ~S yields that:~%  ~S~%  ~S~%"
+	qx x (pathname-components x)
+	qy y (pathname-components y)))
     (t
-     (format t "These two expressions yield paths that are not pathname-equal~%")
-     (format t "the first expression ~S yields this:~%  ~S~%  ~S~%" qx x (pathname-components x))
-     (format t "the other expression ~S yields that:~%  ~S~%  ~S~%" qy y (pathname-components y)))))
+     (error "These two expressions yield paths that are not pathname-equal~%~
+	the first expression ~S yields this:~%  ~S~%  ~S~%
+	the other expression ~S yields that:~%  ~S~%  ~S~%"
+	qx x (pathname-components x)
+	qy y (pathname-components y)))))
 (defmacro assert-pathname-equal (x y)
   `(assert-pathname-equal-helper ',x ,x ',y ,y))
-(defun assert-length-equal-helper (qx qy x y)
+(defun assert-length-equal-helper (qx x qy y)
   (unless (= (length x) (length y))
-    (format t "These two expressions yield sequences of unequal length~%")
-    (format t "The first, ~S, has value ~S of length ~S~%" qx x (length x))
-    (format t "The other, ~S, has value ~S of length ~S~%" qy y (length y))))
+    (error "These two expressions yield sequences of unequal length~%
+	The first, ~S, has value ~S of length ~S~%
+	The other, ~S, has value ~S of length ~S~%"
+           qx x (length x) qy y (length y))))
 (defun assert-pathnames-equal-helper (qx x qy y)
   (assert-length-equal-helper qx x qy y)
   (loop :for n :from 0
@@ -356,8 +361,6 @@ is bound, write a message and exit on an error.  If
 (defmacro with-asdf-conditions ((&optional verbose) &body body)
   `(call-with-asdf-conditions #'(lambda () ,@body) ,verbose))
 
-#+clisp (trace compile-file)
-
 (defun compile-asdf (&optional tag verbose)
   (let* ((alisp (asdf-lisp tag))
          (afasl (asdf-fasl tag))
diff --git a/test/test-concatenate-source.script b/test/test-concatenate-source.script
index 0f43195a6..c6bc7c0e4 100644
--- a/test/test-concatenate-source.script
+++ b/test/test-concatenate-source.script
@@ -21,15 +21,15 @@
 (assert-pathname-equal
  (output-file mcso sys)
  (apply-output-translations
-  (resolve-output "asdf/test/test-concatenate-source.all-systems.lisp")))
-(assert-pathname-equal
+  (resolve-output "asdf/test/test-concatenate-source--all-systems.lisp")))
+(assert-pathnames-equal
  (output-files mcso sys)
  (input-files mccso sys))
 ;; on ECL, we get un-equal pathnames.
 (assert-pathname-equal
  (output-file mccso sys)
- (test-fasl "test-concatenate-source.all-systems.lisp"))
-(assert-pathname-equal
+ (test-fasl "test-concatenate-source--all-systems.lisp"))
+(assert-pathnames-equal
  (output-files mccso sys)
  (input-files mlccso sys))
 (operate 'monolithic-load-compiled-concatenated-source-op sys)
diff --git a/test/test-utilities.script b/test/test-utilities.script
index d1e6cffde..26815de72 100644
--- a/test/test-utilities.script
+++ b/test/test-utilities.script
@@ -39,16 +39,16 @@
  (not (version-satisfies (asdf-version) "666")))
 (assert-pathnames-equal
  (split-native-pathnames-string "foo:bar")
- '("foo" "bar"))
+ '(#p"foo" #p"bar"))
 (assert-pathnames-equal
  (split-native-pathnames-string "foo:bar" :ensure-directory t)
- '("foo/" "bar/"))
+ '(#p"foo/" #p"bar/"))
 (assert-pathnames-equal
  (split-native-pathnames-string "/foo:/bar" :want-absolute t)
- '("/foo" "/bar"))
+ '(#p"/foo" #p"/bar"))
 (assert-pathnames-equal
  (split-native-pathnames-string "/foo:/bar" :want-absolute t :ensure-directory t)
- '("/foo/" "/bar/"))
+ '(#p"/foo/" #p"/bar/"))
 (assert-equal
  (mapcar 'location-function-p
          '((:function f)
@@ -174,3 +174,25 @@
 (assert-equal nil (fishy-asdf-exported-symbols))
 
 (delete-package* :asdf-test-package-1)
+
+(ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/c/"))
+(ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/d/"))
+(ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/e/"))
+(register-directory *asdf-directory*)
+(register-directory *uiop-directory*)
+(copy-file (system-source-file :uiop) (subpathname *build-directory* "deleteme/a/1.x"))
+(copy-file (system-source-file :uiop) (subpathname *build-directory* "deleteme/a/b/2"))
+(assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/c/")))
+(assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/d/")))
+(assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/")))
+(assert (probe-file* (subpathname *build-directory* "deleteme/a/1.x")))
+(assert (probe-file* (subpathname *build-directory* "deleteme/a/b/2")))
+(delete-empty-directory (subpathname *build-directory* "deleteme/a/b/e/"))
+(assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/"))))
+(delete-directory-tree (subpathname *build-directory* "deleteme/")
+                       :validate (lambda (x) (and (<= 5 (length (pathname-directory x)))
+                                                  (subpathp x *build-directory*))))
+(assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/c/"))))
+(assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/d/"))))
+(assert (not (probe-file* (subpathname *build-directory* "deleteme/a/1.x"))))
+(assert (not (probe-file* (subpathname *build-directory* "deleteme/a/b/2"))))
diff --git a/uiop/filesystem.lisp b/uiop/filesystem.lisp
index 625ce2211..df1bc8ee7 100644
--- a/uiop/filesystem.lisp
+++ b/uiop/filesystem.lisp
@@ -9,7 +9,7 @@
    ;; Native namestrings
    #:native-namestring #:parse-native-namestring
    ;; Probing the filesystem
-   #:truename* #:safe-file-write-date #:probe-file*
+   #: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
@@ -24,7 +24,7 @@
    ;; Simple filesystem operations
    #:ensure-all-directories-exist
    #:rename-file-overwriting-target
-   #:delete-file-if-exists))
+   #: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
@@ -132,10 +132,18 @@ or the original (parsed) pathname if it is false (the default)."
                              (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)
-                               #+clozure '(:follow-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)
@@ -170,7 +178,11 @@ or the original (parsed) pathname if it is false (the default)."
         (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 ((entries (ignore-errors (directory* (merge-pathnames* pattern 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)
@@ -217,10 +229,10 @@ or the original (parsed) pathname if it is false (the default)."
                      :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
 
   (defun collect-sub*directories (directory collectp recursep collector)
-    (when (funcall collectp directory)
-      (funcall collector directory))
+    (when (call-function collectp directory)
+      (call-function collector directory))
     (dolist (subdir (subdirectories directory))
-      (when (funcall recursep subdir)
+      (when (call-function recursep subdir)
         (collect-sub*directories subdir collectp recursep collector)))))
 
 ;;; Resolving symlinks somewhat
@@ -478,6 +490,79 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
                  #+clozure :if-exists #+clozure :rename-and-delete))
 
   (defun delete-file-if-exists (x)
-    (when x (handler-case (delete-file x) (file-error () nil)))))
-
+    (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 (sb-ext:delete-directory 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 (sb-ext:delete-directory directory-pathname :recursive t)
+       ;; 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)))))))
 
diff --git a/uiop/lisp-build.lisp b/uiop/lisp-build.lisp
index 9e04104a4..d489f3615 100644
--- a/uiop/lisp-build.lisp
+++ b/uiop/lisp-build.lisp
@@ -673,9 +673,8 @@ it will filter them appropriately."
                    :for n :from 1
                    :for f = (add-pathname-suffix
                              output (format nil "-FASL~D" n))
-                   :do ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
-                   (concatenate-files (list i) f)
-                   (push f fasls))
+                   :do (copy-file i f)
+                       (push f fasls))
              (ignore-errors (lispworks:delete-system :fasls-to-concatenate))
              (eval `(scm:defsystem :fasls-to-concatenate
                       (:default-pathname ,(pathname-directory-pathname output))
diff --git a/uiop/stream.lisp b/uiop/stream.lisp
index 8ed2306a8..9aec12ec1 100644
--- a/uiop/stream.lisp
+++ b/uiop/stream.lisp
@@ -14,7 +14,7 @@
    #:with-output #:output-string #:with-input
    #:with-input-file #:call-with-input-file
    #:finish-outputs #:format! #:safe-format!
-   #:copy-stream-to-stream #:concatenate-files
+   #: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
@@ -246,6 +246,10 @@ Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
                                  :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)
diff --git a/uiop/uiop.asd b/uiop/uiop.asd
index 24ff669fe..f4833a59f 100644
--- a/uiop/uiop.asd
+++ b/uiop/uiop.asd
@@ -2,8 +2,11 @@
 (in-package :asdf)
 
 (defun call-without-redefinition-warnings (thunk)
-  (handler-bind (((or #+clozure ccl:compiler-warning
-                     #+cmu kernel:simple-style-warning)
+  (handler-bind (((or
+                   #+allegro simple-warning
+                   #+clozure ccl:compiler-warning
+                   #+cmu kernel:simple-style-warning
+                   #-(or allegro clozure cmu) warning)
                    #'muffle-warning))
     (funcall thunk)))
 
diff --git a/upgrade.lisp b/upgrade.lisp
index 268e20c78..ea2759ba8 100644
--- a/upgrade.lisp
+++ b/upgrade.lisp
@@ -52,7 +52,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
          ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
          ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
          ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
-         (asdf-version "2.32.11")
+         (asdf-version "2.32.12")
          (existing-version (asdf-version)))
     (setf *asdf-version* asdf-version)
     (when (and existing-version (not (equal asdf-version existing-version)))
diff --git a/version.lisp-expr b/version.lisp-expr
index ea59c4012..f5f7a194a 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -1 +1 @@
-"2.32.11"
+"2.32.12"
-- 
GitLab