Commit e6f50e36 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

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
parent e6a97dc3
......@@ -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.
......
......@@ -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 ()
......
......@@ -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)
......
;;; -*- 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))))))
......
......@@ -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))
......
......@@ -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)
......
......@@ -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"))))
......@@ -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)))))))
......@@ -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))
......
......@@ -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)
......
......@@ -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)))
......
......@@ -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)))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment