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

2.26.111: fix embarrassing bugs in ensure-pathname

parent c13fac5c
......@@ -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
......
......@@ -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)))
......
......@@ -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))))
......
......@@ -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")
......
(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"))))
......
......@@ -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*))
......@@ -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))
......
......@@ -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
......
;; -*- 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>.
......
......@@ -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)
......
......@@ -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)