From 77a4f4461d5bb316e06e195bd1716bd8eaeeda78 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Mon, 28 Jan 2013 14:52:12 -0500 Subject: [PATCH] 2.26.160: fix getcwd for cmucl Also, separate filesystem access functions from pathname object munging. --- Makefile | 14 +- asdf-driver.asd | 9 +- asdf.asd | 2 +- configuration.lisp | 2 +- driver.lisp | 4 +- filesystem.lisp | 448 +++++++++++++++++++++++++ header.lisp | 2 +- lisp-build.lisp | 7 +- os.lisp | 40 ++- pathname.lisp | 537 +++--------------------------- run-program.lisp | 2 +- stream.lisp | 2 +- test/test-system-pathnames.script | 2 - upgrade.lisp | 2 +- version.lisp-expr | 2 +- 15 files changed, 549 insertions(+), 526 deletions(-) create mode 100644 filesystem.lisp diff --git a/Makefile b/Makefile index fc21e14c4..e00afdf5c 100644 --- a/Makefile +++ b/Makefile @@ -42,7 +42,7 @@ XCL ?= xcl # website, tag, install header_lisp := header.lisp -driver_lisp := package.lisp common-lisp.lisp utility.lisp os.lisp pathname.lisp stream.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp backward-driver.lisp driver.lisp +driver_lisp := package.lisp common-lisp.lisp utility.lisp os.lisp pathname.lisp filesystem.lisp stream.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp backward-driver.lisp driver.lisp defsystem_lisp := upgrade.lisp component.lisp system.lisp cache.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp # Making ASDF itself should be our first, default, target: @@ -51,11 +51,19 @@ build/asdf.lisp: $(wildcard *.lisp) cat $(header_lisp) $(driver_lisp) $(defsystem_lisp) > $@ # This quickly locates such mistakes as unbalanced parentheses: -load: build/asdf.lisp - rlwrap sbcl \ +load: load-in-sbcl + +load-in-sbcl: build/asdf.lisp + rlwrap sbcl --eval '(setf *load-verbose* t *compile-verbose* t)' \ `for i in $(driver_lisp) $(defsystem_lisp) ; do echo --load $$i ; done` \ --eval '(in-package :asdf)' +load-in-cmucl: build/asdf.lisp + rlwrap cmucl -eval '(setf *load-verbose* t *compile-verbose* t *gc-verbose* nil)' \ + `for i in $(driver_lisp) $(defsystem_lisp) ; do echo -load $$i ; done` \ + -eval '(in-package :asdf)' + + install: archive-copy bump: bump-version diff --git a/asdf-driver.asd b/asdf-driver.asd index aa3d0780d..93ea577a2 100644 --- a/asdf-driver.asd +++ b/asdf-driver.asd @@ -2,7 +2,9 @@ (in-package :asdf) (defun call-without-redefinition-warnings (thunk) - (handler-bind (#+clozure (ccl:compiler-warning #'muffle-warning)) + (handler-bind ((or #+clozure ccl:compiler-warning + #+cmu kernel:simple-style-warning) + #'muffle-warning) (funcall thunk))) (defsystem :asdf-driver @@ -20,8 +22,9 @@ that you can't portably construct a complete program without using them." (:file "common-lisp" :depends-on ("package")) (:file "utility" :depends-on ("common-lisp")) (:file "os" :depends-on ("utility")) - (:file "pathname" :depends-on ("os")) - (:file "stream" :depends-on ("pathname")) + (:file "pathname" :depends-on ("utility")) + (:file "filesystem" :depends-on ("os" "pathname")) + (:file "stream" :depends-on ("filesystem")) (:file "image" :depends-on ("stream")) (:file "run-program" :depends-on ("stream")) (:file "lisp-build" :depends-on ("image")) diff --git a/asdf.asd b/asdf.asd index 29665831a..755252d8e 100644 --- a/asdf.asd +++ b/asdf.asd @@ -62,7 +62,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.26.159" ;; to be automatically updated by make bump-version + :version "2.26.160" ;; 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/configuration.lisp b/configuration.lisp index b4dccd9ae..59b6ff9f0 100644 --- a/configuration.lisp +++ b/configuration.lisp @@ -4,7 +4,7 @@ (asdf/package:define-package :asdf/configuration (:recycle :asdf/configuration :asdf) (:use :asdf/common-lisp :asdf/utility - :asdf/pathname :asdf/stream :asdf/os :asdf/image) + :asdf/os :asdf/pathname :asdf/filesystem :asdf/stream :asdf/image) (:export #:get-folder-path #:user-configuration-directories #:system-configuration-directories diff --git a/driver.lisp b/driver.lisp index 950ed7c9d..48334b9ef 100644 --- a/driver.lisp +++ b/driver.lisp @@ -4,13 +4,13 @@ (asdf/package:define-package :asdf/driver (:nicknames :d :asdf-driver :asdf-utils) (:use :asdf/common-lisp :asdf/package :asdf/utility - :asdf/pathname :asdf/stream :asdf/os :asdf/image + :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image :asdf/run-program :asdf/lisp-build :asdf/configuration :asdf/backward-driver) (:reexport ;; NB: excluding asdf/common-lisp ;; which include all of CL with compatibility modifications on select platforms. :asdf/package :asdf/utility - :asdf/pathname :asdf/stream :asdf/os :asdf/image + :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image :asdf/run-program :asdf/lisp-build :asdf/configuration :asdf/backward-driver)) diff --git a/filesystem.lisp b/filesystem.lisp new file mode 100644 index 000000000..fd8cf7de3 --- /dev/null +++ b/filesystem.lisp @@ -0,0 +1,448 @@ +;;;; ------------------------------------------------------------------------- +;;;; Portability layer around Common Lisp filesystem access + +(asdf/package:define-package :asdf/filesystem + (:recycle :asdf/pathname :asdf) + (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname) + (:export + ;; Native namestrings + #:native-namestring #:parse-native-namestring + ;; Probing the filesystem + #:truename* #:safe-file-write-date #:probe-file* + #: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)) +(in-package :asdf/filesystem) + +;;; Native namestrings, as seen by the operating system calls rather than Lisp +(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 +(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?) + (handler-case (file-write-date 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 + (handler-case + (or + #+allegro + (probe-file p :follow-symlinks truename) + #-(or allegro clisp gcl2.6) + (if truename + (probe-file p) + (and (ignore-errors + #+(or cmu scl) (unix:unix-stat (ext:unix-namestring (translate-logical-pathname p))) + #+(and lispworks unix) (system:get-file-stat p) + #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring (translate-logical-pathname p))) + #-(or cmu (and lispworks unix) sbcl scl) + (file-write-date p)) + 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* (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) + #+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 ((entries (ignore-errors (directory* (merge-pathnames* pattern dir))))) + (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 (funcall collectp directory) + (funcall collector directory)) + (dolist (subdir (subdirectories directory)) + (when (funcall recursep subdir) + (collect-sub*directories subdir collectp recursep collector)))) + +;;; Resolving symlinks somewhat +(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-pathname-absolute 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 + +(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)) (merge-pathnames* p defaults)) + (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 +(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 +(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 on-error &allow-other-keys) + (apply 'parse-native-namestring (getenvp x) + :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)) + + diff --git a/header.lisp b/header.lisp index 725ef3a8f..495ab43f8 100644 --- a/header.lisp +++ b/header.lisp @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.26.159: Another System Definition Facility. +;;; This is ASDF 2.26.160: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. diff --git a/lisp-build.lisp b/lisp-build.lisp index c9d750a33..698841266 100644 --- a/lisp-build.lisp +++ b/lisp-build.lisp @@ -84,13 +84,15 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (defvar *uninteresting-compiler-conditions* (append + ;;#+clozure '(ccl:compiler-warning) + #+cmu '("Deleting unreachable code.") #+sbcl - `(sb-c::simple-compiler-note + '(sb-c::simple-compiler-note "&OPTIONAL and &KEY found in the same lambda list: ~S" sb-int:package-at-variance sb-kernel:uninteresting-redefinition sb-kernel:undefined-alien-style-warning - ;; sb-ext:implicit-generic-function-warning ; controversial, but let's allow it by default. + ;; sb-ext:implicit-generic-function-warning ; Controversial. Let's allow it by default. sb-kernel:lexical-environment-too-complex sb-grovel-unknown-constant-condition ; defined above. ;; BEWARE: the below four are controversial to include here. @@ -98,7 +100,6 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when sb-kernel:redefinition-with-defgeneric sb-kernel:redefinition-with-defmethod sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs - ;;#+clozure '(ccl:compiler-warning) '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop "Conditions that may be skipped while compiling") diff --git a/os.lisp b/os.lisp index 7d2a91831..c800baaa9 100644 --- a/os.lisp +++ b/os.lisp @@ -194,6 +194,12 @@ then returning the non-empty string value of the variable" ;;; Current directory +#+(or cmu scl) +(defun* parse-unix-namestring* (unix-namestring) + (multiple-value-bind (host device directory name type version) + (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring)) + (make-pathname :host (or host #+cmu lisp::*unix-host*) :device device + :directory directory :name name :type type :version version))) (defun* getcwd () "Get the current working directory as per POSIX getcwd(3), as a pathname object" @@ -202,8 +208,8 @@ then returning the non-empty string value of the variable" #+allegro (excl::current-directory) #+clisp (ext:default-directory) #+clozure (ccl:current-directory) - #+(or cmu scl) (ext:parse-unix-namestring - (nth-value 1 (unix:unix-current-directory)) :ensure-directory t) + #+(or cmu scl) (parse-unix-namestring* + (strcat (nth-value 1 (unix:unix-current-directory)) "/")) #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? #+ecl (ext:getcwd) #+gcl (parse-namestring ;; this is a joke. Isn't there a better way? @@ -216,21 +222,21 @@ then returning the non-empty string value of the variable" (error "getcwd not supported on your implementation"))) (defun* chdir (x) - "Change current directory, as per POSIX chdir(2)" - (declare (ignorable x)) - (or #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (namestring x)) - #+allegro (excl:chdir x) - #+clisp (ext:cd x) - #+clozure (setf (ccl:current-directory) x) - #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x)) - #+cormanlisp (unless (zerop (win32::_chdir (namestring x))) - (error "Could not set current directory to ~A" x)) - #+ecl (ext:chdir x) - #+genera (setf *default-pathname-defaults* (pathname x)) - #+lispworks (hcl:change-directory x) - #+mkcl (mk-ext:chdir x) - #+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)) - (error "chdir not supported on your implementation"))) + "Change current directory, as per POSIX chdir(2), to a given pathname object" + (if-let (x (pathname x)) + (or #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (namestring x)) + #+allegro (excl:chdir x) + #+clisp (ext:cd x) + #+clozure (setf (ccl:current-directory) x) + #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x)) + #+cormanlisp (unless (zerop (win32::_chdir (namestring x))) + (error "Could not set current directory to ~A" x)) + #+ecl (ext:chdir x) + #+genera (setf *default-pathname-defaults* x) + #+lispworks (hcl:change-directory x) + #+mkcl (mk-ext:chdir x) + #+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)) + (error "chdir not supported on your implementation")))) ;;;; ----------------------------------------------------------------- diff --git a/pathname.lisp b/pathname.lisp index d5287d420..30c64c607 100644 --- a/pathname.lisp +++ b/pathname.lisp @@ -1,66 +1,44 @@ ;;;; ------------------------------------------------------------------------- ;;;; Portability layer around Common Lisp pathnames +;; This layer allows for portable manipulation of pathname objects themselves, +;; which all is necessary prior to any access the filesystem or environment. (asdf/package:define-package :asdf/pathname (:recycle :asdf/pathname :asdf) - (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os) + (:use :asdf/common-lisp :asdf/package :asdf/utility) (:export - #:*resolve-symlinks* - ;; Making pathnames, portably + ;; Making and merging pathnames, portably #:normalize-pathname-directory-component #:denormalize-pathname-directory-component #:merge-pathname-directory-components #:*unspecific-pathname-type* #:make-pathname* #:make-pathname-component-logical #:make-pathname-logical #:merge-pathnames* + #:nil-pathname #:*nil-pathname* #:with-pathname-defaults ;; Predicates #:pathname-equal #:logical-pathname-p #:physical-pathname-p #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p ;; Directories #:pathname-directory-pathname #:pathname-parent-directory-pathname #:directory-pathname-p #:ensure-directory-pathname - ;; defaults - #:nil-pathname #:with-pathname-defaults #:*nil-pathname* ;; Parsing filenames #:component-name-to-pathname-components #:split-name-type #:parse-unix-namestring #:unix-namestring #:split-unix-namestring-directory-components - #:native-namestring #:parse-native-namestring + ;; Absolute and relative pathnames #:subpathname #:subpathname* - ;; Wildcard pathnames - #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden - ;; probe filesystem - #:truename* #:safe-file-write-date #:probe-file* - #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories - #:collect-sub*directories - ;; Absolute vs relative pathnames #:ensure-pathname-absolute #:pathname-root #:pathname-host-pathname #:subpathp - ;; Resolving symlinks somewhat - #:truenamize #:resolve-symlinks #:resolve-symlinks* ;; Checking constraints - #:ensure-pathname - ;; 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 + #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints + ;; Wildcard pathnames + #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden ;; Translate a pathname #:relativize-directory-component #:relativize-pathname-directory #:directory-separator-for-host #:directorize-pathname-host-device #:translate-pathname* #:*output-translation-function*)) - (in-package :asdf/pathname) -;;; User-visible parameters -(defvar *resolve-symlinks* t - "Determine whether or not ASDF resolves symlinks when defining systems. - -Defaults to T.") - - ;;; Normalizing pathnames across implementations (defun* normalize-pathname-directory-component (directory) @@ -195,6 +173,23 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." :type (funcall unspecific-handler type) :version (funcall unspecific-handler version)))))) +(defun* nil-pathname (&optional (defaults *default-pathname-defaults*)) + "A pathname that is as neutral as possible for use as defaults + when merging, making or parsing pathnames" + ;; 19.2.2.2.1 says a NIL host can mean a default host; + ;; see also "valid physical pathname host" in the CLHS glossary, that suggests + ;; strings and lists of strings or :unspecific + ;; But CMUCL decides to die on NIL. + (make-pathname* :directory nil :name nil :type nil :version nil :device nil + :host (or #+cmu lisp::*unix-host*) + ;; the default shouldn't matter, but we really want something physical + :defaults defaults)) + +(defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname)))) + +(defmacro with-pathname-defaults ((&optional defaults) &body body) + `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) ,@body)) + ;;; Some pathname predicates @@ -321,26 +316,7 @@ actually-existing directory." :name nil :type nil :version nil :defaults pathspec)))) -;;; defaults -(defun* nil-pathname (&optional (defaults *default-pathname-defaults*)) - "A pathname that is as neutral as possible for use as defaults - when merging, making or parsing pathnames" - ;; 19.2.2.2.1 says a NIL host can mean a default host; - ;; see also "valid physical pathname host" in the CLHS glossary, that suggests - ;; strings and lists of strings or :unspecific - ;; But CMUCL decides to die on NIL. - (make-pathname* :directory nil :name nil :type nil :version nil :device nil - :host (or #+cmu lisp::*unix-host*) - ;; the default shouldn't matter, but we really want something physical - :defaults defaults)) - -(defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname)))) - -(defmacro with-pathname-defaults ((&optional defaults) &body body) - `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) ,@body)) - - -;;; Parsing filenames and lists thereof +;;; Parsing filenames (defun* split-unix-namestring-directory-components (unix-namestring &key ensure-directory dot-dot) "Splits the path string UNIX-NAMESTRING, returning four values: @@ -517,36 +493,7 @@ or if it is a PATHNAME but some of its components are not recognized." (t (or (null type) (err)))))))))) -(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))) - +;;; Absolute and relative pathnames (defun* subpathname (pathname subpath &key type) "This function takes a PATHNAME and a SUBPATH and a TYPE. If SUBPATH is already a PATHNAME object (not namestring), @@ -564,185 +511,6 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." (subpathname (ensure-directory-pathname pathname) subpath :type type))) -;;; Wildcard pathnames -(defparameter *wild* (or #+cormanlisp "*" :wild)) -(defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild)) -(defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors)) -(defparameter *wild-file* - (make-pathname :directory nil :name *wild* :type *wild* - :version (or #-(or allegro abcl xcl) *wild*))) -(defparameter *wild-directory* - (make-pathname* :directory `(:relative ,*wild-directory-component*) - :name nil :type nil :version nil)) -(defparameter *wild-inferiors* - (make-pathname* :directory `(:relative ,*wild-inferiors-component*) - :name nil :type nil :version nil)) -(defparameter *wild-path* - (merge-pathnames* *wild-file* *wild-inferiors*)) - -(defun* wilden (path) - (merge-pathnames* *wild-path* path)) - - -;;; Probing the filesystem -(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?) - (handler-case (file-write-date 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 - (handler-case - (or - #+allegro - (probe-file p :follow-symlinks truename) - #-(or allegro clisp gcl2.6) - (if truename - (probe-file p) - (and (ignore-errors - #+(or cmu scl) (unix:unix-stat (ext:unix-namestring (translate-logical-pathname p))) - #+(and lispworks unix) (system:get-file-stat p) - #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring (translate-logical-pathname p))) - #-(or cmu (and lispworks unix) sbcl scl) - (file-write-date p)) - 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* (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) - #+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 ((entries (ignore-errors (directory* (merge-pathnames* pattern dir))))) - (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 (funcall collectp directory) - (funcall collector directory)) - (dolist (subdir (subdirectories directory)) - (when (funcall recursep subdir) - (collect-sub*directories subdir collectp recursep collector)))) - - ;;; Pathname host and its root (defun* pathname-root (pathname) (make-pathname* :directory '(:absolute) @@ -770,7 +538,7 @@ or the original (parsed) pathname if it is false (the default)." (defun* ensure-pathname-absolute (path &optional defaults (on-error 'error)) (cond ((absolute-pathname-p path)) - ((stringp path) (ensure-pathname-absolute (pathname path) defaults)) + ((stringp path) (ensure-pathname-absolute (pathname path) defaults on-error)) ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path)) ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults)))) (or (if (absolute-pathname-p default-pathname) @@ -784,232 +552,24 @@ or the original (parsed) pathname if it is false (the default)." path defaults)))) -;;; Resolving symlinks somewhat -(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-pathname-absolute 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)) - -(defun* resolve-symlinks* (path) - (if *resolve-symlinks* - (and path (resolve-symlinks path)) - path)) - - -;;; Check pathname constraints - -(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)) (merge-pathnames* p defaults)) - (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)))) - - -;;; Environment pathnames -(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 on-error &allow-other-keys) - (apply 'parse-native-namestring (getenvp x) - :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) - (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)) - - -;;; Pathname defaults and current directory -(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))) +;;; Wildcard pathnames +(defparameter *wild* (or #+cormanlisp "*" :wild)) +(defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild)) +(defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors)) +(defparameter *wild-file* + (make-pathname :directory nil :name *wild* :type *wild* + :version (or #-(or allegro abcl xcl) *wild*))) +(defparameter *wild-directory* + (make-pathname* :directory `(:relative ,*wild-directory-component*) + :name nil :type nil :version nil)) +(defparameter *wild-inferiors* + (make-pathname* :directory `(:relative ,*wild-inferiors-component*) + :name nil :type nil :version nil)) +(defparameter *wild-path* + (merge-pathnames* *wild-file* *wild-inferiors*)) + +(defun* wilden (path) + (merge-pathnames* *wild-path* path)) ;;; Translate a pathname @@ -1094,7 +654,6 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." (t (translate-pathname path absolute-source destination)))) -;;; Hook for output translations -(defvar *output-translation-function* 'identity) +(defvar *output-translation-function* 'identity) ; Hook for output translations diff --git a/run-program.lisp b/run-program.lisp index f2c19e006..127a51740 100644 --- a/run-program.lisp +++ b/run-program.lisp @@ -3,7 +3,7 @@ (asdf/package:define-package :asdf/run-program (:recycle :asdf/run-program :xcvb-driver) - (:use :asdf/common-lisp :asdf/utility :asdf/pathname :asdf/stream :asdf/os) + (:use :asdf/common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/filesystem :asdf/stream) (:export ;;; Escaping the command invocation madness #:easy-sh-character-p #:escape-sh-token #:escape-sh-command diff --git a/stream.lisp b/stream.lisp index 9d4172164..082667ec0 100644 --- a/stream.lisp +++ b/stream.lisp @@ -3,7 +3,7 @@ (asdf/package:define-package :asdf/stream (:recycle :asdf/stream) - (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname) + (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname :asdf/filesystem) (:export #:*default-stream-element-type* #:*stderr* #:setup-stderr #:with-safe-io-syntax #:call-with-safe-io-syntax diff --git a/test/test-system-pathnames.script b/test/test-system-pathnames.script index 2130cb6b6..f66cf57b4 100644 --- a/test/test-system-pathnames.script +++ b/test/test-system-pathnames.script @@ -1,7 +1,5 @@ ;;; -*- Lisp -*- -(trace parse-unix-namestring asdf::determine-system-directory) - (defsystem :test-system-pathnames :pathname "sources/level1" :components diff --git a/upgrade.lisp b/upgrade.lisp index c6bb0debe..f347e0cff 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -35,7 +35,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.26.159") + (asdf-version "2.26.160") (existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version)) diff --git a/version.lisp-expr b/version.lisp-expr index 4b661b43d..22c1efebd 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -1 +1 @@ -"2.26.159" +"2.26.160" -- GitLab