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