From eceb8c10f1b73bf452b08a891ea4e9a0d2122adb Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Fri, 18 Jan 2013 03:19:17 -0500 Subject: [PATCH] 2.26.111: fix embarrassing bugs in ensure-pathname --- Makefile | 11 ++-- action.lisp | 17 ------ asdf.asd | 2 +- bin/bump-version | 2 + bin/make-helper.lisp | 96 +++++++++++++++--------------- bin/make-tarball | 43 ++++++++------ bundle.lisp | 4 +- component.lisp | 13 +++++ header.lisp | 2 +- os.lisp | 16 ++--- pathname.lisp | 135 +++++++++++++++++++++---------------------- upgrade.lisp | 2 +- version.lisp-expr | 2 +- 13 files changed, 175 insertions(+), 170 deletions(-) diff --git a/Makefile b/Makefile index a1efe833..d0f47490 100644 --- a/Makefile +++ b/Makefile @@ -53,10 +53,13 @@ load: build/asdf.lisp install: archive-copy -archive: - ${SBCL} --userinit /dev/null --sysinit /dev/null --load bin/make-helper.lisp \ - --eval "(rewrite-license)" --eval "(quit)" - bin/make-tarball +bump-version: build/asdf.lisp + ./bin/bump-version + +archive: build/asdf.lisp + #${SBCL} --userinit /dev/null --sysinit /dev/null --load bin/make-helper.lisp \ + # --eval "(rewrite-license)" --eval "(quit)" + ./bin/make-tarball archive-copy: archive build/asdf.lisp git checkout release diff --git a/action.lisp b/action.lisp index 5b4d1c13..be0abfd1 100644 --- a/action.lisp +++ b/action.lisp @@ -11,8 +11,6 @@ #:action #:explain #:operation-description #:downward-operation #:upward-operation - #:source-file #:c-source-file #:java-source-file - #:static-file #:doc-file #:html-file #:operation-error #:error-component #:error-operation #:component-depends-on #:component-self-dependencies #:input-files #:output-files #:output-file #:operation-done-p @@ -136,21 +134,6 @@ You can put together sentences using this phrase.")) (declare (ignorable o c)) nil) - -;;;; File components - -(defclass source-file (file-component) - ((type :initform nil))) ;; NB: many systems have come to rely on this default. -(defclass c-source-file (source-file) - ((type :initform "c"))) -(defclass java-source-file (source-file) - ((type :initform "java"))) -(defclass static-file (source-file) - ((type :initform nil))) -(defclass doc-file (static-file) ()) -(defclass html-file (doc-file) - ((type :initform "html"))) - (defmethod input-files ((o operation) (c file-component)) (or (loop :for (dep-o) :in (component-self-dependencies o c) :append (or (output-files dep-o c) (input-files dep-o c))) diff --git a/asdf.asd b/asdf.asd index a3374f9d..34cc87f0 100644 --- a/asdf.asd +++ b/asdf.asd @@ -15,7 +15,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.26.110" ;; to be automatically updated by bin/bump-revision + :version "2.26.111" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:module "build" :components ((:file "asdf")))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf)))) diff --git a/bin/bump-version b/bin/bump-version index c1d77cb0..77d88c32 100755 --- a/bin/bump-version +++ b/bin/bump-version @@ -7,6 +7,8 @@ (in-package :fare-utils) +(asdf-debug) + (defparameter *versioned-files* '(("version.lisp-expr" "\"" "\"") ("asdf.asd" " :version \"" "\" ;; to be automatically updated by bin/bump-revision") diff --git a/bin/make-helper.lisp b/bin/make-helper.lisp index a23f68a3..b55dfedb 100644 --- a/bin/make-helper.lisp +++ b/bin/make-helper.lisp @@ -1,19 +1,17 @@ -(in-package #:common-lisp-user) +(load (make-pathname :name "prelude" :type "lisp" :defaults *load-pathname*) + :verbose nil :print nil) -#+(or) -(build-web-page "/repository/git/asdf/test/results/" "/tmp/x.html" :if-exists :supersede) +(in-package :asdf) -(defvar *make-helper-home* *load-truename*) +(defvar *make-helper-home* *load-truename*) - -;;; metatilities-base +;;; metatilities-base ;;; because sometimes copy and paste is just too easy -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro generate-time-part-function (part-name position) - (let ((function-name (intern (concatenate 'string - (symbol-name 'time) "-" (symbol-name part-name))))) - `(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((function-name (intern (strcat (symbol-name 'time) "-" (symbol-name part-name))))) + `(eval-when (:compile-toplevel :load-toplevel :execute) (export ',function-name) (defun ,function-name (&optional (universal-time (get-universal-time)) @@ -49,7 +47,7 @@ is divisible by four but not by 100 or if it is divisible by 400." (= (mod year 400) 0))) (defun day-of-year (date) - "Returns the day of the year [1 to 366] of the specified date [which must be \(CL\) universal time format.]" + "Returns the day of the year [1 to 366] of the specified date [which must be \(CL\) universal time format.]" (let ((leap-year? (leap-year-p (time-year date)))) (+ (loop for month from 1 to (1- (time-month date)) sum (days-in-month month leap-year?)) @@ -71,7 +69,7 @@ is divisible by four but not by 100 or if it is divisible by 400." "Returns the name of `day-of-the-week`. The parameter should be a number between 0 and 6 where 0 represents Sunday and 6 repressents Saturday. The optional format argument can be either :long or :short. In the latter case, the return string will be of length three; in the former it will be the complete name of the appropriate day." (check-type day-of-the-week (mod 7)) (check-type format (member :long :short)) - (nth day-of-the-week + (nth day-of-the-week (case format (:long (nth +longer-format-index+ +dow-output-list)) (:short (nth +shorter-format-index+ +dow-output-list))))) @@ -80,7 +78,7 @@ is divisible by four but not by 100 or if it is divisible by 400." "Returns the name \(in English\) of the month. Format can be :long or :short." (check-type month (integer 1 12)) (check-type format (member :long :short)) - (nth (1- month) + (nth (1- month) (case format (:long (nth +longer-format-index+ +month-output-list+)) (:short (nth +shorter-format-index+ +month-output-list+))))) @@ -95,7 +93,7 @@ is divisible by four but not by 100 or if it is divisible by 400." %B - Full month name %c - Shorthand for \"%X %x\", the locale format for date and time %d - Day of the month as a decimal number [01-31] -%e - Same as %d but does not print the leading 0 for days 1 through 9 +%e - Same as %d but does not print the leading 0 for days 1 through 9 [unlike strftime[], does not print a leading space] %F - Milliseconds as a decimal number [000-999] %H - Hour based on a 24-hour clock as a decimal number [00-23] @@ -106,79 +104,79 @@ is divisible by four but not by 100 or if it is divisible by 400." %p - AM/PM designation for the locale %S - Second as a decimal number [00-59] %w - Weekday as a decimal number [0-6], where Sunday is 0 -%x - Date using the date representation for the locale, including +%x - Date using the date representation for the locale, including the time zone [produces different results from strftime[]] -%X - Time using the time representation for the locale [produces +%X - Time using the time representation for the locale [produces different results from strftime[]] %y - Year without century [00-99] %Y - Year with century [such as 1990] -%Z - Time zone name [such as Pacific Daylight Time; +%Z - Time zone name [such as Pacific Daylight Time; produces different results from strftime[]] %z - Time zone offset in hours and minutes from GMT [HHMM] None of %c, %F, %p, %x, %X, %Z, %z are implemented." (declare (ignore time-zone)) (let ((format-length (length format))) - (format + (format stream "~{~A~}" - (loop for index = 0 then (1+ index) - while (< index format-length) collect + (loop for index = 0 then (1+ index) + while (< index format-length) collect (let ((char (aref format index))) - (cond + (cond ((char= #\% char) (setf char (aref format (incf index))) - (cond + (cond ;; %% - A '%' character ((char= char #\%) #\%) - + ;; %a - Abbreviated weekday name ((char= char #\a) (day->string (time-day-of-week date) :short)) - + ;; %A - Full weekday name ((char= char #\A) (day->string (time-day-of-week date) :long)) - + ;; %b - Abbreviated month name ((char= char #\b) (month->string (time-month date) :short)) - + ;; %B - Full month name ((char= char #\B) (month->string (time-month date) :long)) - + ;; %d - Day of the month as a decimal number [01-31] ((char= char #\d) (format nil "~2,'0D" (time-date date))) - - ;; %e - Same as %d but does not print the leading 0 for days 1 through 9 + + ;; %e - Same as %d but does not print the leading 0 for days 1 through 9 ;; Unlike strftime, does not print a leading space ((char= char #\e) (format nil "~D" (time-date date))) - + ;; %H - Hour based on a 24-hour clock as a decimal number [00-23] ((char= char #\H) (format nil "~2,'0D" (time-hour date))) - + ;; %I - Hour based on a 12-hour clock as a decimal number [01-12] ((char= char #\I) (format nil "~2,'0D" (1+ (mod (time-hour date) 12)))) - + ;; %j - Day of the year as a decimal number [001-366] ((char= char #\j) (format nil "~3,'0D" (day-of-year date))) - + ;; %m - Month as a decimal number [01-12] ((char= char #\m) (format nil "~2,'0D" (time-month date))) - + ;; %M - Minute as a decimal number [00-59] ((char= char #\M) (format nil "~2,'0D" (time-minute date))) - + ;; %S - Second as a decimal number [00-59] ((char= char #\S) (format nil "~2,'0D" (time-second date))) - + ;; %w - Weekday as a decimal number [0-6], where Sunday is 0 ((char= char #\w) (format nil "~D" (time-day-of-week date))) - + ;; %y - Year without century [00-99] - ((char= char #\y) + ((char= char #\y) (let ((year-string (format nil "~,2A" (time-year date)))) (subseq year-string (- (length year-string) 2)))) - + ;; %Y - Year with century [such as 1990] ((char= char #\Y) (format nil "~D" (time-year date))) - + (t (error "Ouch - unknown formatter '%~c" char)))) (t char))))))) @@ -203,7 +201,7 @@ None of %c, %F, %p, %x, %X, %Z, %z are implemented." (format stream "~&<html>~&<head>") (when title (format stream "~&<title>~a</title>" title)) - (when style-sheet + (when style-sheet (unless (search ".css" style-sheet) (setf style-sheet (concatenate 'string style-sheet ".css"))) (format stream "~&<link type='text/css' href='~a' rel='stylesheet' />" @@ -227,7 +225,7 @@ None of %c, %F, %p, %x, %X, %Z, %z are implemented." (html-header stream title style-sheet) (format stream "~&~%<h1>ASDF Test results</h1>~%") - (dolist (pathname (directory + (dolist (pathname (directory (merge-pathnames (make-pathname :name :wild :type "text") input-directory))) (print pathname) @@ -250,9 +248,9 @@ None of %c, %F, %p, %x, %X, %Z, %z are implemented." (flag-length (length flag))) (loop for line = (read-line in nil :eof) until (eq line :eof) do - (when (and (> (length line) flag-length) + (when (and (> (length line) flag-length) (string-equal flag (subseq line 0 flag-length))) - (if (eq state :running) + (if (eq state :running) (return) (setf state :starting))) (when (eq state :running) @@ -261,24 +259,24 @@ None of %c, %F, %p, %x, %X, %Z, %z are implemented." (setf state :running))))))) (defun rewrite-license () - (let* ((*default-pathname-defaults* + (let* ((*default-pathname-defaults* (make-pathname :name nil :type nil :defaults *make-helper-home*)) (output (merge-pathnames (make-pathname :name "LICENSE" :directory '(:relative :up))))) (when (probe-file output) (delete-file output)) - (extract-license - (merge-pathnames (make-pathname :name "asdf" :type "lisp" + (extract-license + (merge-pathnames (make-pathname :name "header" :type "lisp" :directory '(:relative :up))) output))) (defun write-test-web-pages () - (let* ((*default-pathname-defaults* + (let* ((*default-pathname-defaults* (make-pathname :name nil :type nil :defaults *make-helper-home*)) (source (merge-pathnames (make-pathname :directory '(:relative :up "test" "results")))) - (output (merge-pathnames (make-pathname + (output (merge-pathnames (make-pathname :directory '(:relative :up "website" "output") :name "test-results" :type "html")))) diff --git a/bin/make-tarball b/bin/make-tarball index 39906f90..d74b721a 100755 --- a/bin/make-tarball +++ b/bin/make-tarball @@ -8,8 +8,6 @@ (in-package :asdf) -(asdf-debug) - ;;; Make sure asdf.lisp is built. (asdf:build-system :asdf/generate) @@ -17,7 +15,7 @@ (defparameter *asdf-dir* (ensure-pathname (system-relative-pathname :asdf ()) :want-physical t :want-absolute t - :want-existing t :truename t)) + :want-existing t :ensure-truename t)) (defparameter /asdf-dir/ (native-namestring *asdf-dir*)) @@ -31,20 +29,20 @@ (native-namestring *build-dir*)) (defparameter *version* - (safe-read-first-file-form + (safe-read-file-form (subpathname *asdf-dir* "version.lisp-expr"))) (defparameter *asdf-driver* (format nil "asdf-driver-~A" *version*)) (defun enough-namestring! (base pathname) - (let ((e (enough-namestring b p))) - (assert (relative-pathname e)) + (let ((e (enough-namestring base pathname))) + (assert (relative-pathname-p e)) e)) (defun enough-namestrings (base pathnames) (loop :with b = (ensure-pathname base :want-absolute t :want-directory t) :for p :in pathnames - :collect (enough-namestring! base p))) + :collect (enough-namestring! p base))) (defun system-source-files (system) (let* ((sys (find-system system)) @@ -55,7 +53,8 @@ (operated-components sys :other-systems nil :goal-operation 'load-op - :keep-operation 'load-op)) + :keep-operation 'load-op + :keep-component 'file-component)) (pathnames (mapcar 'component-pathname components))) (enough-namestrings dir pathnames))) @@ -71,13 +70,21 @@ (defun tarname (name) (strcat name ".tar.gz")) +(defun run-program* (x) + (format t "~A~%" x) + (run-program/ x)) + (defun make-tarball-under-build (name base files) + (check-type name string) + (ensure-pathname base :want-absolute t :want-existing t :want-directory t) + (dolist (f files) + (check-type f string)) (let* ((/base/ (native-namestring (ensure-pathname base :want-absolute t :want-directory t - :want-existing t :want-truename t))) + :want-existing t :ensure-truename t))) (destination (ensure-pathname name @@ -97,16 +104,18 @@ (/files/ (mapcar 'native-namestring files))) (assert (< 6 (length (pathname-directory destination)))) - (run-program/ `("rm" "-rf" ,/destination/)) + (when (probe-file* destination) + (error "Destination ~S already exists, not taking chances - you can delete it yourself." + destination)) (ensure-directories-exist destination) - (run-program/ (format nil "cd ~S && cp -lax --parents ~{~S ~} ~S" + (run-program* (format nil "cd ~S && cp -lax --parents ~{~S ~} ~S" /base/ /files/ /destination/)) - (run-program/ (format nil "tar zcvfC ~S ~S ~S/" - /tarball/ /build/ name)) - (run-program/ `("rm" "-rf" ,/destination/)))) + (run-program* (format nil "tar zcvfC ~S ~S ~S/" + /tarball/ /build-dir/ name)) + (run-program* `("rm" "-rf" ,/destination/)))) -(make-tarball-under-build *asdf-driver* *asdf-directory* *asdf-driver-files*) -(make-tarball-under-build *asdf-only* *asdf-directory* *asdf-only-files*) +(make-tarball-under-build *asdf-driver* *asdf-dir* *driver-files*) +(make-tarball-under-build *asdf-only* *asdf-dir* *asdf-only-files*) -(run-program/ (format nil "cd ~S && tar zcf build/asdf-~A.tar.gz build/asdf.lisp $(git ls-files)" +(run-program* (format nil "cd ~S && tar zcf build/asdf-~A.tar.gz build/asdf.lisp $(git ls-files)" /asdf-dir/ *version*)) diff --git a/bundle.lisp b/bundle.lisp index ff2e01d8..a95ff340 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -218,7 +218,7 @@ #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal type (compile-file-type))))) (defun* operated-components (system &key (goal-operation 'load-op) (keep-operation goal-operation) - (component-type t) other-systems) + (component-type t) (keep-component t) other-systems) (let ((goal-op (make-operation goal-operation))) (flet ((filter (o c) (declare (ignore o)) @@ -227,7 +227,7 @@ (loop :for (o . c) :in (gather-actions goal-op system :other-systems other-systems :filter #'filter) - :when (typep o keep-operation) + :when (and (typep o keep-operation) (typep c keep-component)) :collect c)))) (defgeneric* trivial-system-p (component)) diff --git a/component.lisp b/component.lisp index 4be0c3ba..723d0fa3 100644 --- a/component.lisp +++ b/component.lisp @@ -10,6 +10,8 @@ #:component-parent #:component-system #:component-parent-pathname #:child-component #:parent-component #:module #:file-component + #:source-file #:c-source-file #:java-source-file + #:static-file #:doc-file #:html-file #:source-file-type ;; backward-compatibility #:component-in-order-to #:component-sibling-dependencies #:component-if-feature #:around-compile-hook @@ -131,6 +133,17 @@ another pathname in a degenerate way.")) (defclass file-component (child-component) ((type :accessor file-type :initarg :type))) ; no default +(defclass source-file (file-component) + ((type :initform nil))) ;; NB: many systems have come to rely on this default. +(defclass c-source-file (source-file) + ((type :initform "c"))) +(defclass java-source-file (source-file) + ((type :initform "java"))) +(defclass static-file (source-file) + ((type :initform nil))) +(defclass doc-file (static-file) ()) +(defclass html-file (doc-file) + ((type :initform "html"))) (defclass parent-component (component) ((children diff --git a/header.lisp b/header.lisp index 1d6fa3ef..bbf1603d 100644 --- a/header.lisp +++ b/header.lisp @@ -1,5 +1,5 @@ ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.26.110: Another System Definition Facility. +;;; This is ASDF 2.26.111: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. diff --git a/os.lisp b/os.lisp index 5c83aced..7fa65913 100644 --- a/os.lisp +++ b/os.lisp @@ -123,16 +123,16 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" (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 (error-arguments () eap) &allow-other-keys) - (declare (ignore error-arguments)) +(defun* getenv-pathname (x &rest constraints &key on-error &allow-other-keys) (apply 'parse-native-namestring (getenvp x) - (if eap constraints - (list* :error-arguments '("~? from (getenv ~S)") constraints)))) -(defun* getenv-pathnames (x &rest constraints &key (error-arguments () eap) &allow-other-keys) - (declare (ignore error-arguments)) + :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) - (if eap constraints - (list* :error-arguments '("~? from (getenv ~S)") constraints)))) + :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) diff --git a/pathname.lisp b/pathname.lisp index 9ae0e2c6..ec8a46d4 100644 --- a/pathname.lisp +++ b/pathname.lisp @@ -66,7 +66,7 @@ Defaults to T.") -;;; The hell of portably making and merging pathnames! +;;; Normalizing pathnames across implementations (defun* normalize-pathname-directory-component (directory) "Given a pathname directory component, return an equivalent form that is a list" @@ -158,46 +158,6 @@ and make a new pathname with corresponding components and specified logical HOST :type (make-pathname-component-logical (pathname-type pathname)) :version (make-pathname-component-logical (pathname-version pathname)))) -(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) - "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that -if the SPECIFIED pathname does not have an absolute directory, -then the HOST and DEVICE both come from the DEFAULTS, whereas -if the SPECIFIED pathname does have an absolute directory, -then the HOST and DEVICE both come from the SPECIFIED. -This is what users want on a modern Unix or Windows operating system, -unlike the MERGE-PATHNAME behavior. -Also, if either argument is NIL, then the other argument is returned unmodified; -this is unlike MERGE-PATHNAME which always merges with a pathname, -by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." - (when (null specified) (return-from merge-pathnames* defaults)) - (when (null defaults) (return-from merge-pathnames* specified)) - #+scl - (ext:resolve-pathname specified defaults) - #-scl - (let* ((specified (pathname specified)) - (defaults (pathname defaults)) - (directory (normalize-pathname-directory-component (pathname-directory specified))) - (name (or (pathname-name specified) (pathname-name defaults))) - (type (or (pathname-type specified) (pathname-type defaults))) - (version (or (pathname-version specified) (pathname-version defaults)))) - (labels ((unspecific-handler (p) - (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity))) - (multiple-value-bind (host device directory unspecific-handler) - (ecase (first directory) - ((:absolute) - (values (pathname-host specified) - (pathname-device specified) - directory - (unspecific-handler specified))) - ((nil :relative) - (values (pathname-host defaults) - (pathname-device defaults) - (merge-pathname-directory-components directory (pathname-directory defaults)) - (unspecific-handler defaults)))) - (make-pathname* :host host :device device :directory directory - :name (funcall unspecific-handler name) - :type (funcall unspecific-handler type) - :version (funcall unspecific-handler version)))))) ;;; Some pathname predicates @@ -221,6 +181,11 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." (=? pathname-type) (=? pathname-version))))))) +(defun* logical-pathname-p (x) + (typep x 'logical-pathname)) + +(defun* physical-pathname-p (x) + (and (pathnamep x) (not (logical-pathname-p x)))) (defun* absolute-pathname-p (pathspec) "If PATHSPEC is a pathname or namestring object that parses as a pathname @@ -251,6 +216,48 @@ i.e. its name starts with a dot." (and pathname (equal (first-char (pathname-name pathname)) #\.))) +;;;; merging pathnames +(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) + "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that +if the SPECIFIED pathname does not have an absolute directory, +then the HOST and DEVICE both come from the DEFAULTS, whereas +if the SPECIFIED pathname does have an absolute directory, +then the HOST and DEVICE both come from the SPECIFIED. +This is what users want on a modern Unix or Windows operating system, +unlike the MERGE-PATHNAME behavior. +Also, if either argument is NIL, then the other argument is returned unmodified; +this is unlike MERGE-PATHNAME which always merges with a pathname, +by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." + (when (null specified) (return-from merge-pathnames* defaults)) + (when (null defaults) (return-from merge-pathnames* specified)) + #+scl + (ext:resolve-pathname specified defaults) + #-scl + (let* ((specified (pathname specified)) + (defaults (pathname defaults)) + (directory (normalize-pathname-directory-component (pathname-directory specified))) + (name (or (pathname-name specified) (pathname-name defaults))) + (type (or (pathname-type specified) (pathname-type defaults))) + (version (or (pathname-version specified) (pathname-version defaults)))) + (labels ((unspecific-handler (p) + (if (logical-pathname-p p) #'make-pathname-component-logical #'identity))) + (multiple-value-bind (host device directory unspecific-handler) + (ecase (first directory) + ((:absolute) + (values (pathname-host specified) + (pathname-device specified) + directory + (unspecific-handler specified))) + ((nil :relative) + (values (pathname-host defaults) + (pathname-device defaults) + (merge-pathname-directory-components directory (pathname-directory defaults)) + (unspecific-handler defaults)))) + (make-pathname* :host host :device device :directory directory + :name (funcall unspecific-handler name) + :type (funcall unspecific-handler type) + :version (funcall unspecific-handler version)))))) + ;;; Directories (defun* pathname-directory-pathname (pathname) "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, @@ -875,12 +882,6 @@ For the latter case, we ought pick random suffix and atomically open it." `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))) ;;; Basic pathnames -(defun* logical-pathname-p (x) - (typep x 'logical-pathname)) - -(defun* physical-pathname-p (x) - (and (pathnamep x) (not (logical-pathname-p x)))) - (defun* sane-physical-pathname (&key defaults (keep t) fallback want-existing) (flet ((sanitize (x) (setf x (and x (ignore-errors (translate-logical-pathname x)))) @@ -989,7 +990,7 @@ Otherwise, this will be the root of some implementation-dependent filesystem hos (defun* ensure-pathname (pathname &key - error-arguments + on-error defaults type dot-dot want-pathname want-logical want-physical ensure-physical @@ -1015,15 +1016,14 @@ 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 ERROR-ARGUMENTS arguments, if provided, -will be passed on to the error primitive, together with three arguments: -the pathname, the keyword :reason, and a list (KEYWORD FORMAT ARGUMENTS) - the keyword that corresponds to that constraint name - a format string describing the error - and a list of any additional arguments required by said format string. -This makes it usable whether you are using the short or long variants of ERROR, -modulo your error object having to recognize the keyword :reason -in case you use the long variant. +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: @@ -1050,20 +1050,17 @@ ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EX ENSURE-TRUENAME replaces the pathname by its truename, or errors if not possible. TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." (block nil - (flet ((report-error (on-error keyword description &rest arguments) - (let ((err (append (or error-arguments '("Invalid pathname ~S: ~*~{~*~?~}")) - (list pathname :reason (list keyword description arguments))))) - (ecase on-error - ((error t) (apply 'error err)) - ((cerror) (apply 'cerror "ignore pathname constraint" err)) - ((ignore) (return 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 ,constraint ',(intern* constraint :keyword) ,@arguments)) + `(report-error ',(intern* constraint :keyword) ,@arguments)) (check (constraint condition &rest arguments) `(when ,constraint (unless ,condition (err ,constraint ,@arguments)))) - (transform (flag condition expr) - `(when ,flag + (transform (transform condition expr) + `(when ,transform (,@(if condition `(when ,condition) '(progn)) (setf p ,expr))))) (etypecase p @@ -1073,14 +1070,14 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." 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 pathname (return 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* defaults p)) + (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) diff --git a/upgrade.lisp b/upgrade.lisp index 4328357c..d216bf81 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -45,7 +45,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.110") + (asdf-version "2.26.111") (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 c44ad2ab..1d236db4 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -1 +1 @@ -"2.26.110" +"2.26.111" -- GitLab