A system named foo/bar will be looked up in a registered file foo.asd.
This makes it possible to sensibly name several systems in a .asd file
and still have asdf find them all by name.
We now use it to not have the asdf header be part of asdf-driver.
A new generic operation build-op makes it possible to deal with
the fact that the default operation for systems need not be load-op,
yet that the end-user does not want to have to know the exact operation
for each of the system he uses.
ensure-pathname has been improved again, and its clients tweaked.
remove-keys was made more sensible by using EQL rather than STRING-EQUAL.
:version need not take the first form in a file, but can take
a path to a subform. This makes it possible to get the exact subform
in a Lisp source file that has the string.
See SUB-OBJECT for how these paths work.
Cleanup of the semantics of ENSURE-FUNCTION on CONSes: use APPLY, not EVAL.
## MAJOR FAIL: gclcvs -- Compiler bug fixed upstream, but gcl fails to compile on modern Linuxen.
## grep for #+/#- features in the test/ directory to see plenty of disabled tests.
-## Make sure testing remains within the confines of this filesystem tree
-export ASDF_OUTPUT_TRANSLATIONS := (:output-translations (t ("${sourceDirectory}/build/fasls" :implementation)) :ignore-inherited-configuration)
-export CL_SOURCE_REGISTRY := (:source-registry (:tree "${sourceDirectory}") :ignore-inherited-configuration)
-
-
lisp ?= sbcl
ABCL ?= abcl
# website, tag, install
-driver_lisp := header.lisp package.lisp compatibility.lisp utility.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp backward-driver.lisp driver.lisp
+header_lisp := header.lisp
+driver_lisp := package.lisp compatibility.lisp utility.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp backward-driver.lisp driver.lisp
asdf_lisp := upgrade.lisp component.lisp system.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 footer.lisp
# Making ASDF itself should be our first, default, target:
build/asdf.lisp: $(wildcard *.lisp)
mkdir -p build
- cat $(driver_lisp) $(asdf_lisp) > $@
+ cat $(header_lisp) $(driver_lisp) $(asdf_lisp) > $@
# This quickly locates such mistakes as unbalanced parentheses:
-load:
- rlwrap sbcl `for i in $(driver_lisp) $(asdf_lisp) ; do echo --load $$i ; done`
+load: build/asdf.lisp
+ rlwrap sbcl \
+ `for i in $(driver_lisp) $(asdf_lisp) ; do echo --load $$i ; done` \
+ --eval '(in-package :asdf)'
install: archive-copy
### Count lines separately for asdf-driver and asdf itself:
wc:
@wc $(driver_lisp) | sort -n ; echo ; \
- wc $(asdf_lisp) | sort -n ; \
+ wc $(header_lisp) $(asdf_lisp) | sort -n ; \
echo ; \
wc $(driver_lisp) $(asdf_lisp) | tail -n 1
#:action
#:explain #:operation-description
#:downward-operation #:upward-operation
- #:file-component
#:source-file #:c-source-file #:java-source-file
#:static-file #:doc-file #:html-file
#:operation-error #:error-component #:error-operation
;;;; File components
-(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)
;; I guess we work with the original source file, then
(list (component-pathname c))))
-(defmethod source-file-type ((component parent-component) system) ; not just for source-file. ASDF3: rename.
- (declare (ignorable component system))
- :directory)
-(defmethod source-file-type ((component file-component) system)
- (declare (ignorable system))
- (file-type component))
-
;;;; Done performing
(mark-operation-done operation component)
(return)))))
+;;; Generic build operation
+(defmethod component-depends-on ((o build-op) (c component))
+ `((,(or (component-build-operation c) 'load-op) ,c)))
+
;;; -*- mode: lisp -*-
-(defpackage :asdf-driver-system (:use :cl :asdf))
+(in-package :asdf)
(defun call-without-redefinition-warnings (thunk)
(handler-bind (#+clozure (ccl:compiler-warning #'muffle-warning))
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
- :version "2.26.105" ;; to be automatically updated by bin/bump-revision
+ :version "2.26.106" ;; 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))))
#+(and clisp (not asdf2.27))
(rename-package :asdf :asdf-utilities)
+
+#+asdf2.27
+(defsystem :asdf/generate
+ :licence "MIT"
+ :description "All the components needed to build asdf.lisp"
+ :description "Generate asdf.lisp based on this and monolithic-concatenate-source-op"
+ :defsystem-depends-on (:asdf)
+ :class :bundle-system
+ :build-operation monolithic-concatenate-source-op
+ :bundle-pathname "build/asdf"
+ :translate-output-p nil
+ :serial t
+ :around-compile call-without-redefinition-warnings ;; be the same as asdf-driver
+ :depends-on (:asdf/header :asdf-driver)
+ :components
+ ((:file "upgrade")
+ (:file "component")
+ (:file "system" :depends-on ("component"))
+ (:file "find-system" :depends-on ("system"))
+ (:file "find-component" :depends-on ("find-system"))
+ (:file "operation")
+ (:file "action" :depends-on ("find-component" "operation"))
+ (:file "lisp-action" :depends-on ("action"))
+ (:file "plan" :depends-on ("action"))
+ (:file "operate" :depends-on ("plan"))
+ (:file "output-translations" :depends-on ("operate"))
+ (:file "source-registry" :depends-on ("find-system"))
+ (:file "backward-internals" :depends-on ("action" "operate"))
+ (:file "defsystem" :depends-on ("backward-internals"))
+ (:file "bundle" :depends-on ("lisp-action"))
+ (:file "concatenate-source" :depends-on ("lisp-action"))
+ (:file "backward-interface" :depends-on ("lisp-action"))
+ (:file "interface")
+ (:file "footer" :depends-on ("interface"))))
+
+(defsystem :asdf/header
+ :components
+ ((:static-file "header.lisp")))
;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS")
(multiple-value-bind (relabs path filename file-only)
(split-unix-namestring-directory-components
- unix-style-namestring :want-directory force-directory)
+ unix-style-namestring :ensure-directory force-directory)
(declare (ignore file-only))
(when (and force-relative (not (eq relabs :relative)))
(error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>")
:asdf/system :asdf/component :asdf/find-system :asdf/action)
(:export ;; for internal use
#:%refresh-component-inline-methods
- #:%resolve-if-component-dep-fails))
+ #:%resolve-if-component-dep-fails
+ #:make-sub-operation))
(in-package :asdf/backward-internals)
;;;; Backward compatibility with "inline methods"
:when (eq feature? 'feature) :do
(setf (component-if-feature c) feature)))))
+(when-upgrade (:when (fboundp 'make-sub-operation))
+ (defun* make-sub-operation (c o dep-c dep-o)
+ (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
(in-package :fare-utils)
+(defparameter *versioned-files*
+ '(("version.lisp-expr" "\"" "\"")
+ ("asdf.asd" " :version \"" "\" ;; to be automatically updated by bin/bump-revision")
+ ("header.lisp" "This is ASDF " ": Another System Definition Facility.")
+ ("upgrade.lisp" " (asdf-version \"" "\")")))
+
(defvar *adir* (asdf:system-relative-pathname :asdf nil))
(defun afile (x) (subpathname *adir* x))
(defparameter *new-version* nil)
(defun next-version (v)
- (let ((pv (parse-version v)))
+ (let ((pv (parse-version v 'error)))
(incf (third pv))
(unparse-version pv)))
(defun version-from-file ()
- (safe-read-first-file-form *version-file*))
+ (safe-read-file-form *version-file*))
(defun versions-from-argv (argv)
- (ecase (length argv)
- ((2) (values (second argv) (first argv)))
- ((1) (values (version-from-file) (first argv)))
- ((0) (let ((old (version-from-file)))
- (values old (next-version old))))))
+ (labels ((check (old new)
+ (parse-version old 'error)
+ (parse-version new 'error)
+ (values old new)))
+ (ecase (length argv)
+ ((2) (check (second argv) (first argv)))
+ ((1) (check (version-from-file) (first argv)))
+ ((0) (let ((old (version-from-file)))
+ (check old (next-version old)))))))
(multiple-value-setq (*old-version* *new-version*)
(versions-from-argv *command-line-arguments*))
-(format t "Bumping ASDF version from ~A to ~A~%" *old-version* *new-version*)
+(a "Bumping ASDF version from " *old-version* " to " *new-version*)
(deftype byte-vector () '(array (unsigned-byte 8) (*)))
(clobber-file-with-vector file written-contents :external-format external-format)
(format t "done.~%")))))
-(defun version-transformer (new-version file prefix suffix)
+(defun version-transformer (new-version file prefix suffix &optional dont-warn)
(let* ((qprefix (cl-ppcre:quote-meta-chars prefix))
(versionrx "([0-9]+(\\.[0-9]+)+)")
(qsuffix (cl-ppcre:quote-meta-chars suffix))
(lambda (text)
(multiple-value-bind (new-text foundp)
(cl-ppcre:regex-replace regex text replacement)
- (unless (or foundp t)
+ (unless (or foundp dont-warn)
(warn "Missing version in ~A" (file-namestring file)))
(values new-text foundp)))))
-(defparameter *versioned-files*
- '(("version.lisp-expr" "\"" "\"")
- ("asdf.asd" " :version \"" "\" ;; to be automatically updated by bin/bump-revision")
- ("header.lisp" "This is ASDF " ": Another System Definition Facility.")
- ("upgrade.lisp" " (asdf-version \"" "\")")))
-
(defun transform-file (new-version file prefix suffix)
(maybe-replace-file (afile file) (version-transformer new-version file prefix suffix)))
(let ((lines (read-file-lines (afile file))))
(dolist (l lines (progn (warn "Couldn't find a match in ~A" file) nil))
(multiple-value-bind (new-text foundp)
- (funcall (version-transformer new-version file prefix suffix) l)
+ (funcall (version-transformer new-version file prefix suffix t) l)
(when foundp
(format t "Found a match:~% ==> ~A~%Replacing with~% ==> ~A~%~%"
l new-text)
(defun z () (apply 'test-transform-file *new-version* (first *versioned-files*)))
(transform-files)
+
+(a "Re-generate ASDF with bumped version")
+(asdf:build-system :asdf/generate)
(asdf-debug)
-(describe (find-system :asdf))
+;;; Make sure asdf.lisp is built.
+(asdf:build-system :asdf/generate)
-(defparameter *ad* (find-system :asdf-driver))
+;;; ASDF directory
(defparameter *asdf-dir*
- (ensure-pathname (system-source-directory *ad*)
- :want-existing t :want-absolute t))
-(defun apath (x) (subpathname *asdf-dir* x))
-(defun ann (x) (native-namestring (apath x)))
-(defparameter *build-dir* (apath "build/"))
-(defparameter /build-dir/ (ann "build/"))
-(defun bpath (x) (subpathname *build-dir* x))
-(defun bnn (x) (native-namestring (bpath x)))
-(defparameter *files*
- (list* "asdf-driver.asd" "version.lisp-expr"
- (loop :for c :in (operated-components
- *ad* :goal-operation 'load-op
- :keep-operation 'load-op)
- :for n = (enough-namestring (component-pathname c)
- *asdf-directory*)
- :when (typep c 'cl-source-file)
- :collect n)))
+ (ensure-pathname (system-relative-pathname :asdf ())
+ :want-physical t :want-absolute t
+ :want-existing t :truename t))
+(defparameter /asdf-dir/
+ (native-namestring *asdf-dir*))
+
+;;; build directory
+(defparameter *build-dir*
+ (ensure-pathname
+ "build/" :defaults *asdf-dir*
+ :want-relative t :ensure-absolute t
+ :ensure-subpath t))
+(defparameter /build-dir/
+ (native-namestring *build-dir*))
+
(defparameter *version*
- (safe-read-first-file-form (apath "version.lisp-expr")))
-(defparameter *name* (format nil "asdf-driver-~A" *version*))
-(defparameter *tarname* (strcat *name* ".tar.gz"))
-(defparameter dirname/ (strcat *name* "/"))
-(defparameter *destination*
- (ensure-pathname (bpath dirname/)
- :want-directory t :want-absolute t))
-(assert (< 6 (length (pathname-directory *destination*))))
-(defparameter /destination/ (native-namestring *destination*))
-(run-program/ `("rm" "-rf" ,/destination/))
-(ensure-directory-exists *destination*)
-(run-program/ `("ln" ,@(mapcar 'ann *files*) ,/destination/))
-(run-program/ (format nil "cd ~S && tar zcf ~S ~S"
- ,/build-dir/, ,*tarname* ,dirname/))
-(run-program/ `("rm" "-rf" ,/destination/))
+ (safe-read-first-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))
+ 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)))
+
+(defun system-source-files (system)
+ (let* ((sys (find-system system))
+ (dir (ensure-pathname
+ (system-source-directory sys)
+ :want-absolute t :want-directory t))
+ (components
+ (operated-components
+ sys :other-systems nil
+ :goal-operation 'load-op
+ :keep-operation 'load-op))
+ (pathnames (mapcar 'component-pathname components)))
+ (enough-namestrings dir pathnames)))
+
+(defparameter *driver-files*
+ (list* "asdf-driver.asd" "version.lisp-expr"
+ (system-source-files :asdf-driver)))
+
+(defparameter *asdf-only*
+ (format nil "asdf-only-~A" *version*))
+(defparameter *asdf-only-files*
+ (list* "asdf.asd" "version.lisp-expr"
+ (system-source-files :asdf/generate)))
+
+(defun tarname (name) (strcat name ".tar.gz"))
+
+(defun make-tarball-under-build (name base files)
+ (let* ((/base/
+ (native-namestring
+ (ensure-pathname
+ base
+ :want-absolute t :want-directory t
+ :want-existing t :want-truename t)))
+ (destination
+ (ensure-pathname
+ name
+ :defaults *build-dir*
+ :want-relative t :ensure-absolute t
+ :ensure-subpath t :ensure-directory t))
+ (/destination/
+ (native-namestring destination))
+ (/tarball/
+ (native-namestring
+ (ensure-pathname
+ (tarname name)
+ :defaults *build-dir*
+ :want-relative t :ensure-absolute t
+ :ensure-subpath t :want-file t
+ :ensure-directories-exist t)))
+ (/files/
+ (mapcar 'native-namestring files)))
+ (assert (< 6 (length (pathname-directory destination))))
+ (run-program/ `("rm" "-rf" ,/destination/))
+ (ensure-directories-exist destination)
+ (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/))))
+
+(make-tarball-under-build *asdf-driver* *asdf-directory* *asdf-driver-files*)
+(make-tarball-under-build *asdf-only* *asdf-directory* *asdf-only-files*)
+
+(run-program/ (format nil "cd ~S && tar zcf build/asdf-~A.tar.gz build/asdf.lisp $(git ls-files)"
+ /asdf-dir/ *version*))
#:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op
#:monolithic-op #:monolithic-bundle-op #:dependency-files
#:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op
- #:program-op #:program-system
+ #:program-op
#:compiled-file #:precompiled-system #:prebuilt-system
#:operation-monolithic-p
#:user-system-p #:user-system #:trivial-system-p
(translate-output-p
:initform nil :initarg :translate-output-p :accessor component-translate-output-p)))
-(defclass program-system (bundle-system)
- ((bundle-pathname :initarg :executable-name)
- (bundle-operation :initform 'program-op)))
-
(defun* bundle-pathname-type (bundle-type)
(etypecase bundle-type
((eql :no-output-file) nil) ;; should we error out instead?
&allow-other-keys)
(operation-original-initargs instance)
(setf (operation-original-initargs instance)
- (remove-keys '(lisp-files epilogue-code prologue-code) original-initargs)
+ (remove-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs)
(monolithic-op-prologue-code instance) prologue-code
(monolithic-op-epilogue-code instance) epilogue-code)
#-ecl (assert (null (or lisp-files epilogue-code prologue-code)))
#+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
(setf (bundle-op-build-args instance)
- (remove-keys '(type monolithic name-suffix)
+ (remove-keys '(:type :monolithic :name-suffix)
(operation-original-initargs instance))))
(defmethod bundle-op-build-args :around ((o lib-op))
(declare (ignorable o c))
nil)
+(defmethod component-depends-on :around ((o bundle-op) (c component))
+ (declare (ignorable o c))
+ (if-bind (op (and (eq (type-of o) 'bundle-op) (component-bundle-operation c)))
+ `((,op ,c))
+ (call-next-method)))
+
(defun* dependency-files (o c &key (test 'identity) (key 'output-files))
(while-collecting (collect)
(visit-dependencies
(merge-pathnames "./asdf-output/")))
(operation (apply #'operate operation-name
system
- (remove-keys '(monolithic type move-here) args)))
+ (remove-keys '(:monolithic :type :move-here) args)))
(system (find-system system))
(files (and system (output-files operation system))))
(if (or move-here (and (null move-here-p)
#:component #:component-find-path
#:component-name #:component-pathname #:component-relative-pathname
#:component-parent #:component-system #:component-parent-pathname
+ #:child-component #:parent-component #:module
+ #:file-component
#:source-file-type ;; backward-compatibility
#:component-in-order-to #:component-sibling-dependencies
#:component-if-feature #:around-compile-hook
#:component-operation-times ;; For internal use only.
;; portable ASDF encoding and implementation-specific external-format
#:component-external-format #:component-encoding
+ #:component-children-by-name #:component-children #:compute-children-by-name
+ #:component-build-operation
+ #:module-default-component-class
+ #:module-components ;; backward-compatibility. DO NOT USE.
;; Internals we'd like to share with the ASDF package.
#:name #:version #:description #:long-description
(defgeneric* component-external-format (component))
(defgeneric* component-encoding (component))
(defgeneric* version-satisfies (component version))
+
+;;; Backward compatible way of computing the FILE-TYPE of a component.
+;;; TODO: find users, have them stop using that.
(defgeneric* source-file-type (component system))
(when-upgrade (:when (find-class 'component nil))
(properties :accessor component-properties :initarg :properties
:initform nil)
;; For backward-compatibility, this slot is part of component rather than child-component
- (parent :initarg :parent :initform nil :reader component-parent)))
+ (parent :initarg :parent :initform nil :reader component-parent)
+ (build-operation
+ :initarg :build-operation :initform nil :reader component-build-operation)))
(defun* component-find-path (component)
(check-type component (or null component))
component))
+;;;; Component hierarchy within a system
+;; The tree typically but not necessarily follows the filesystem hierarchy.
+
+(defclass child-component (component) ())
+
+(defclass file-component (child-component)
+ ((type :accessor file-type :initarg :type))) ; no default
+
+(defclass parent-component (component)
+ ((children
+ :initform nil
+ :initarg :components
+ :reader module-components ; backward-compatibility
+ :accessor component-children)
+ (children-by-name
+ :reader module-components-by-name ; backward-compatibility
+ :accessor component-children-by-name)
+ (default-component-class
+ :initform nil
+ :initarg :default-component-class
+ :accessor module-default-component-class)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun* compute-children-by-name (parent &key only-if-needed-p)
+ (unless (and only-if-needed-p (slot-boundp parent 'children-by-name))
+ (let ((hash (make-hash-table :test 'equal)))
+ (setf (component-children-by-name parent) hash)
+ (loop :for c :in (component-children parent)
+ :for name = (component-name c)
+ :for previous = (gethash name hash)
+ :do (when previous (error 'duplicate-names :name name))
+ (setf (gethash name hash) c))
+ hash))))
+
+(when-upgrade (:when (find-class 'module nil))
+ (defmethod reinitialize-instance :after ((m module) &rest initargs &key)
+ (declare (ignorable m initargs)) (values))
+ (defmethod update-instance-for-redefined-class :after
+ ((m module) added deleted plist &key)
+ (declare (ignorable m added deleted plist))
+ (when (and (member 'children added) (member 'components deleted))
+ (setf (slot-value m 'children)
+ ;; old ECLs provide an alist instead of a plist(!)
+ (if (or #+ecl (consp (first plist))) (or #+ecl (cdr (assoc 'components plist)))
+ (getf plist 'components)))
+ (compute-children-by-name m))))
+
+(defclass module (child-component parent-component)
+ ())
+
+
;;;; component pathnames
(defun* component-parent-pathname (component)
pathname)))
(defmethod component-relative-pathname ((component component))
+ ;; source-file-type is backward-compatibility with ASDF1;
+ ;; we ought to be able to extract this from the component alone with COMPONENT-TYPE.
+ ;; TODO: track who uses it, and have them not use it anymore.
(parse-unix-namestring
(or (and (slot-boundp component 'relative-pathname)
(slot-value component 'relative-pathname))
(component-name component))
:want-relative t
- :type (source-file-type component (component-system component)) ;; backward-compatibility
+ :type (source-file-type component (component-system component))
:defaults (component-parent-pathname component)))
+(defmethod source-file-type ((component parent-component) system)
+ (declare (ignorable component system))
+ :directory)
+
+(defmethod source-file-type ((component file-component) system)
+ (declare (ignorable system))
+ (file-type component))
+
;;;; General component-property - ASDF3: remove? Define clean subclasses, not messy "properties".
#:monolithic-load-concatenated-source-op
#:monolithic-compile-concatenated-source-op
#:monolithic-load-compiled-concatenated-source-op
- #:concatenated-source-system
#:component-concatenated-source-file
#:concatenated-source-file))
(in-package :asdf/concatenate-source)
(defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ())
(defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ())
-(defclass concatenated-source-system (bundle-system)
- ((bundle-pathname :initarg :concatenated-source-file)
- (bundle-operation :initform :load-compiled-concatenated-source-op)))
-
(defmethod input-files ((operation concatenate-source-op) (s system))
(loop :with encoding = (or (component-encoding s) *default-encoding*)
:with other-encodings = '()
:do (report-invalid-form invalid-form-reporter :form form :location file)))
:inherit-configuration)))
-(defun* resolve-relative-location-component (x &key want-directory wilden)
+(defun* resolve-relative-location-component (x &key ensure-directory wilden)
(ensure-pathname
(etypecase x
(pathname x)
(string (parse-unix-namestring
- x :want-directory want-directory))
+ x :ensure-directory ensure-directory))
(cons
(if (null (cdr x))
(resolve-relative-location-component
- (car x) :want-directory want-directory :wilden wilden)
+ (car x) :ensure-directory ensure-directory :wilden wilden)
(let* ((car (resolve-relative-location-component
- (car x) :want-directory t :wilden nil)))
+ (car x) :ensure-directory t :wilden nil)))
(merge-pathnames*
(resolve-relative-location-component
- (cdr x) :want-directory want-directory :wilden wilden)
+ (cdr x) :ensure-directory ensure-directory :wilden wilden)
car))))
((eql :*/) *wild-directory*)
((eql :**/) *wild-inferiors*)
((eql :*.*.*) *wild-file*)
((eql :implementation)
(parse-unix-namestring
- (implementation-identifier) :want-directory t))
+ (implementation-identifier) :ensure-directory t))
((eql :implementation-type)
(parse-unix-namestring
- (string-downcase (implementation-type)) :want-directory t))
+ (string-downcase (implementation-type)) :ensure-directory t))
((eql :hostname)
- (parse-unix-namestring (hostname) :want-directory t)))
+ (parse-unix-namestring (hostname) :ensure-directory t)))
:wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*))))
:want-relative t))
'(:home ".cache" "common-lisp" :implementation)))))
(register-image-restore-hook 'compute-user-cache)
-(defun* resolve-absolute-location-component (x &key want-directory wilden)
+(defun* resolve-absolute-location-component (x &key ensure-directory wilden)
(ensure-pathname
(etypecase x
(pathname x)
(let ((p #-mcl (parse-namestring x)
#+mcl (probe-posix x)))
#+mcl (unless p (error "POSIX pathname ~S does not exist" x))
- (if want-directory (ensure-directory-pathname p) p)))
+ (if ensure-directory (ensure-directory-pathname p) p)))
(cons
(return-from resolve-absolute-location-component
(if (null (cdr x))
(resolve-absolute-location-component
- (car x) :want-directory want-directory :wilden wilden)
+ (car x) :ensure-directory ensure-directory :wilden wilden)
(merge-pathnames*
(resolve-relative-location-component
- (cdr x) :want-directory want-directory :wilden wilden)
+ (cdr x) :ensure-directory ensure-directory :wilden wilden)
(resolve-absolute-location-component
- (car x) :want-directory t :wilden nil)))))
+ (car x) :ensure-directory t :wilden nil)))))
((eql :root)
;; special magic! we return a relative pathname,
;; but what it means to the output-translations is
(if wilden (wilden p) p))))
((eql :home) (user-homedir))
((eql :here) (resolve-absolute-location-component
- *here-directory* :want-directory t :wilden nil))
+ *here-directory* :ensure-directory t :wilden nil))
((eql :user-cache) (resolve-absolute-location-component
- *user-cache* :want-directory t :wilden nil)))
+ *user-cache* :ensure-directory t :wilden nil)))
:wilden (and wilden (not (pathnamep x)))
:want-absolute t))
-(defun* resolve-location (x &key want-directory wilden directory)
- (when directory (setf want-directory t)) ;; :directory backward compatibility, until 2014-01-16.
+(defun* resolve-location (x &key ensure-directory wilden directory)
+ (when directory (setf ensure-directory t)) ;; :directory backward compatibility, until 2014-01-16.
(if (atom x)
- (resolve-absolute-location-component x :want-directory want-directory :wilden wilden)
+ (resolve-absolute-location-component x :ensure-directory ensure-directory :wilden wilden)
(loop :with path = (resolve-absolute-location-component
- (car x) :want-directory (and (or want-directory (cdr x)) t)
+ (car x) :ensure-directory (and (or ensure-directory (cdr x)) t)
:wilden (and wilden (null (cdr x))))
:for (component . morep) :on (cdr x)
- :for dir = (and (or morep want-directory) t)
+ :for dir = (and (or morep ensure-directory) t)
:for wild = (and wilden (not morep))
:do (setf path (merge-pathnames*
(resolve-relative-location-component
- component :want-directory dir :wilden wild)
+ component :ensure-directory dir :wilden wild)
path))
:finally (return path))))
;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and
;; if it is indeed available and an absolute pathname, then
;; the PATHNAME argument is normalized to a relative pathname
- ;; as per PARSE-UNIX-NAMESTRING (with WANT-DIRECTORY T)
+ ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
;; and merged into that DIRECTORY as per SUBPATHNAME.
;; If no absolute pathname was found, we return NIL.
(check-type pathname (or null string pathname))
type name value))
(defun* check-component-input (type name weakly-depends-on
- depends-on components in-order-to)
+ depends-on components)
"A partial test of the values of a component."
(unless (listp depends-on)
(sysdef-error-component ":depends-on must be a list."
type name weakly-depends-on))
(unless (listp components)
(sysdef-error-component ":components must be NIL or a list of components."
- type name components))
- (unless (and (listp in-order-to) (listp (car in-order-to)))
- (sysdef-error-component ":in-order-to must be NIL or a list of components."
- type name in-order-to)))
+ type name components)))
(defun* normalize-version (form pathname)
- (cond
- ((typep form '(or string null)) form)
- ((length=n-p form 2)
+ (etypecase form
+ ((or string null) form)
+ (cons
(ecase (first form)
((:read-file-form)
- (safe-read-first-file-form (subpathname pathname (second form))))))))
+ (destructuring-bind (subpath &key (path 0)) (rest form)
+ (safe-read-file-form (subpathname pathname subpath) :path path)))))))
+
;;; Main parsing function
(defun* parse-component-form (parent options &key previous-serial-component)
(destructuring-bind
- (type name &rest rest &key
- ;; the following list of keywords is reproduced below in the
- ;; remove-keys form. important to keep them in sync
- components pathname
- perform explain output-files operation-done-p
- weakly-depends-on depends-on serial in-order-to
- do-first if-component-dep-fails
- (version nil versionp)
- ;; list ends
- &allow-other-keys) options
+ (type name &rest rest &key
+ ;; the following list of keywords is reproduced below in the
+ ;; remove-keys form. important to keep them in sync
+ components pathname perform explain output-files operation-done-p
+ weakly-depends-on depends-on serial
+ do-first if-component-dep-fails (version nil versionp)
+ ;; list ends
+ &allow-other-keys) options
(declare (ignorable perform explain output-files operation-done-p))
- (check-component-input type name weakly-depends-on depends-on components in-order-to)
+ (check-component-input type name weakly-depends-on depends-on components)
(when (and parent
(find-component parent name)
(not ;; ignore the same object when rereading the defsystem
(typep (find-component parent name)
(class-for-type parent type))))
(error 'duplicate-names :name name))
- (when do-first (error "DO-FIRST is not supported anymore since ASDF 2.27"))
+ (when do-first (error "DO-FIRST is not supported anymore as of ASDF 2.27"))
(let* ((args `(:name ,(coerce-name name)
:pathname ,pathname
,@(when parent `(:parent ,parent))
,@(remove-keys
- '(components pathname if-component-dep-fails
- perform explain output-files operation-done-p
- weakly-depends-on depends-on serial in-order-to)
+ '(:components :pathname :if-component-dep-fails :version
+ :perform :explain :output-files :operation-done-p
+ :weakly-depends-on :depends-on :serial)
rest)))
- (ret (find-component parent name)))
+ (component (find-component parent name)))
(when weakly-depends-on
- (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
+ ;; ASDF3: deprecate this feature and remove it.
+ (appendf depends-on
+ (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
(when previous-serial-component
(push previous-serial-component depends-on))
- (if ret ; preserve identity
- (apply 'reinitialize-instance ret args)
- (setf ret (apply 'make-instance (class-for-type parent type) args)))
- (component-pathname ret) ; eagerly compute the absolute pathname
- (when versionp
- (unless (parse-version (normalize-version
- version (system-source-directory (component-system ret))) nil)
- (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
- version name parent)))
- (when (typep ret 'parent-component)
- (setf (component-children ret)
+ (if component ; preserve identity
+ (apply 'reinitialize-instance component args)
+ (setf component (apply 'make-instance (class-for-type parent type) args)))
+ (component-pathname component) ; eagerly compute the absolute pathname
+ (let ((sysdir (system-source-directory (component-system component)))) ;; requires the previous
+ (when versionp
+ (setf version (normalize-version version sysdir))
+ (unless (parse-version version nil)
+ (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
+ version name parent))
+ (setf (component-version component) version)))
+ (when (typep component 'parent-component)
+ (setf (component-children component)
(loop
:with previous-component = nil
:for c-form :in components
- :for c = (parse-component-form ret c-form
+ :for c = (parse-component-form component c-form
:previous-serial-component previous-component)
:for name = (component-name c)
:collect c
:when serial :do (setf previous-component name)))
- (compute-children-by-name ret))
- (setf (component-sibling-dependencies ret) depends-on) ;; Used by POIU. ASDF3: rename to component-depends-on
- (setf (component-in-order-to ret) in-order-to)
- (%refresh-component-inline-methods ret rest)
- (when if-component-dep-fails (%resolve-if-component-dep-fails if-component-dep-fails ret))
- ret)))
+ (compute-children-by-name component))
+ ;; Used by POIU. ASDF3: rename to component-depends-on
+ (setf (component-sibling-dependencies component) depends-on)
+ (%refresh-component-inline-methods component rest)
+ (when if-component-dep-fails
+ (%resolve-if-component-dep-fails if-component-dep-fails component))
+ component)))
(defun* register-system-definition
(name &rest options &key pathname (class 'system) (source-file () sfp)
(registered (system-registered-p name))
(registered! (if registered
(rplaca registered (safe-file-write-date source-file))
- (register-system (make-instance 'system :name name :source-file source-file))))
+ (register-system
+ (make-instance 'system :name name :source-file source-file))))
(system (reset-system (cdr registered!)
:name name :source-file source-file))
- (component-options (remove-keyword :class options)))
- (setf (gethash name *systems-being-defined*) system)
+ (component-options (remove-key :class options)))
(apply 'load-systems defsystem-depends-on)
;; We change-class AFTER we loaded the defsystem-depends-on
;; since the class might be defined as part of those.
(:use :common-lisp :asdf/driver :asdf/upgrade :asdf/component :asdf/system)
(:export
#:remove-entry-from-registry #:coerce-entry-to-directory
- #:coerce-name #:find-system #:locate-system #:load-sysdef #:with-system-definitions
+ #:coerce-name #:primary-system-name
+ #:find-system #:locate-system #:load-sysdef #:with-system-definitions
#:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems
#:system-definition-error #:missing-component #:missing-requires #:missing-parent
#:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error
(string name)
(t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
+(defun* primary-system-name (name)
+ ;; When a system name has slashes, the file with defsystem is named by
+ ;; the first of the slash-separated components.
+ (first (split-string (coerce-name name) :separator "/")))
+
(defun* system-registered-p (name)
(gethash (coerce-name name) *defined-systems*))
(return (pathname target))))))))))
(defun* sysdef-central-registry-search (system)
- (let ((name (coerce-name system))
+ (let ((name (primary-system-name system))
(to-remove nil)
(to-replace nil))
(block nil
(when (and pathname (not (absolute-pathname-p pathname)))
(setf pathname (ensure-pathname-absolute pathname))
(when found-system
- (%set-system-source-file pathname found-system)))
+ (setf (system-source-file found-system) pathname)))
(when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
(system-source-file previous) pathname)))
- (%set-system-source-file pathname previous)
+ (setf (system-source-file previous) pathname)
(setf previous-time nil))
(values foundp found-system pathname previous previous-time))))
+++ /dev/null
-;;; -*- mode: lisp -*-
-
-(defsystem :generate-asdf
- :licence "MIT"
- :description "All the components needed to build asdf.lisp"
- :description "Generate asdf.lisp based on this and monolithic-concatenate-source-op"
- ;; :defsystem-depends-on (:asdf/bundle)
- :class :concatenated-source-system
- ;; :include-dependencies t
- :translate-output-p nil
- :concatenated-source-file "build/asdf"
- :version (:read-file-form "version.lisp-expr")
- :serial t
- :depends-on (:asdf-driver)
- :components
- ((:file "upgrade")
- (:file "component")
- (:file "system" :depends-on ("component"))
- (:file "find-system" :depends-on ("system"))
- (:file "find-component" :depends-on ("find-system"))
- (:file "operation")
- (:file "action" :depends-on ("find-component" "operation"))
- (:file "lisp-action" :depends-on ("action"))
- (:file "plan" :depends-on ("action"))
- (:file "operate" :depends-on ("plan"))
- (:file "output-translations" :depends-on ("operate"))
- (:file "source-registry" :depends-on ("find-system"))
- (:file "backward-internals" :depends-on ("action" "operate"))
- (:file "defsystem" :depends-on ("backward-internals"))
- (:file "bundle" :depends-on ("lisp-action"))
- (:file "concatenate-source" :depends-on ("lisp-action"))
- (:file "backward-interface" :depends-on ("lisp-action"))
- (:file "interface")
- (:file "footer" :depends-on ("interface"))))
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
-;;; This is ASDF 2.26.105: Another System Definition Facility.
+;;; This is ASDF 2.26.106: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
#:compile-system #:load-system #:load-systems
#:require-system #:test-system #:clear-system
#:operation #:upward-operation #:downward-operation #:make-operation
- #:load-op #:prepare-op #:compile-op #:load-fasl-op #:fasl-op
+ #:build-system #:build-op
+ #:load-op #:prepare-op #:compile-op
#:prepare-source-op #:load-source-op #:test-op
#:feature #:version #:version-satisfies #:upgrade-asdf
#:implementation-identifier #:implementation-type #:hostname
#:needed-in-image-p
#:run-program/ ; the recommended replacement for run-shell-command
#:component-load-dependencies #:run-shell-command ; deprecated, do not use
- #:precompiled-system #:compiled-file
- #+ecl #:make-build #+mkcl #:bundle-system
- #:program-op #:program-system
+ #:bundle-op #:precompiled-system #:compiled-file #:bundle-system
+ #+ecl #:make-build
+ #:program-op #:load-fasl-op #:fasl-op #:lib-op #:binary-op
#:concatenate-source-op
#:load-concatenated-source-op
#:compile-concatenated-source-op
#:monolithic-load-concatenated-source-op
#:monolithic-compile-concatenated-source-op
#:monolithic-load-compiled-concatenated-source-op
- #:concatenated-source-system
- #:component-concatenated-source-file
- #:concatenated-source-file
#:operation-monolithic-p
#:component #:parent-component #:child-component #:system #:module
#:system-source-registry
#:user-source-registry-directory
#:system-source-registry-directory))
-(in-package :asdf/interface)
-
-(when-upgrade (:when (fboundp 'make-sub-operation))
- (defun* make-sub-operation (c o dep-c dep-o)
- (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
(etypecase x
((or pathname string #-(or gcl<2.7 clozure allegro) stream)
(apply 'load x
- #-gcl<2.7 keys #+gcl<2.7 (remove-keyword :external-format keys)))
+ #-gcl<2.7 keys #+gcl<2.7 (remove-key :external-format keys)))
#-(or gcl<2.7 clozure allegro)
;; GCL 2.6 can't load from a string-input-stream
;; ClozureCL 1.6 can only load from file input stream
:asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan)
(:export
#:operate #:oos #:*systems-being-operated* #:*asdf-upgrade-already-attempted*
+ #:build-system
#:load-system #:load-systems #:compile-system #:test-system #:require-system
#:*load-system-operation* #:module-provide-asdf
#:component-loaded-p #:already-loaded-systems
This may change in the future as we will implement component-based strategy
for how to load or compile stuff")
+(defun* build-system (system &rest keys)
+ "Shorthand for `(operate 'asdf:build-op system)`."
+ (apply 'operate 'build-op system keys)
+ t)
+
(defun* load-system (system &rest keys &key force force-not verbose version &allow-other-keys)
"Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details."
(declare (ignore force force-not verbose version))
(defun* reset-asdf-systems ()
(let ((asdf (find-system :asdf)))
+ (setf (component-version asdf) (asdf-version))
;; Invalidate all systems but ASDF itself.
(setf *defined-systems* (make-defined-systems-table))
(register-system asdf)
(:export
#:operation
#:operation-original-initargs ;; backward-compatibility only. DO NOT USE.
+ #:build-op ;; THE generic operation
#:make-operation
#:find-operation))
(in-package :asdf/operation)
(defmethod find-operation (context (spec symbol))
(apply 'make-operation spec (operation-original-initargs context)))
(defmethod operation-original-initargs ((context null)) context)
+
+(defclass build-op (operation) ())
(if (os-unix-p) (unix-namestring p)
(namestring p)))))
-(defun* parse-native-namestring (string &rest constraints &key want-directory &allow-other-keys)
+(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))
#+sbcl (sb-ext:parse-native-namestring string)
#-(or clozure sbcl)
(if (os-unix-p)
- (parse-unix-namestring string :type (when want-directory :directory))
+ (parse-unix-namestring string :ensure-directory ensure-directory)
(parse-namestring string)))))
(pathname
- (if want-directory
+ (if ensure-directory
(and pathname (ensure-directory-pathname pathname))
pathname)))
(apply 'ensure-pathname pathname constraints)))
(if eap constraints
(list* :error-arguments '("~? from (getenv ~S)") constraints))))
(defun* getenv-absolute-directory (x)
- (getenv-pathname x :want-absolute t :want-directory t))
+ (getenv-pathname x :want-absolute t :ensure-directory t))
(defun* getenv-absolute-directories (x)
- (getenv-pathnames x :want-absolute t :want-directory t))
+ (getenv-pathnames x :want-absolute t :ensure-directory t))
;;;; implementation-identifier
#+gcl system::*system-directory*
#+sbcl (if-bind (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
(funcall it)
- (getenv-pathname "SBCL_HOME" :want-directory t)))))
+ (getenv-pathname "SBCL_HOME" :ensure-directory t)))))
(if (and dir truename)
(truename* dir)
dir)))
(defun* default-temporary-directory ()
(or
(when (os-unix-p)
- (or (getenv-pathname "TMPDIR" :want-directory t)
+ (or (getenv-pathname "TMPDIR" :ensure-directory t)
(parse-native-namestring "/tmp/")))
(when (os-windows-p)
- (getenv-pathname "TEMP" :want-directory t))
+ (getenv-pathname "TEMP" :ensure-directory t))
(subpathname (user-homedir) "tmp/")))
(defvar *temporary-directory* nil)
(process-output-translations (pathname dst) :inherit nil :collect collect))
(when src
(let ((trusrc (or (eql src t)
- (let ((loc (resolve-location src :want-directory t :wilden t)))
+ (let ((loc (resolve-location src :ensure-directory t :wilden t)))
(if (absolute-pathname-p loc) (truenamize loc) loc)))))
(cond
((location-function-p dst)
(funcall collect (list trusrc t)))
(t
(let* ((trudst (if dst
- (resolve-location dst :want-directory t :wilden t)
+ (resolve-location dst :ensure-directory t :wilden t)
trusrc)))
(funcall collect (list trudst t))
(funcall collect (list trusrc trudst)))))))))))
;; Wildcard pathnames
#:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden
;; Pathname host and its root
- #:absolute-pathname-p #:hidden-pathname-p
+ #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p
#:pathname-root #:directory-separator-for-host
#:directorize-pathname-host-device
;; defaults
#:delete-file-if-exists
;; Translate a pathname
#:translate-pathname*
- ;; temporary
+ ;; temporary
#:add-pathname-suffix #:tmpize-pathname
#:call-with-staging-pathname #:with-staging-pathname
;; physical pathnames
(pathname-directory pathname))))
pathname))))
+(defun* relative-pathname-p (pathspec)
+ "If PATHSPEC is a pathname or namestring object that parses as a pathname
+possessing a :RELATIVE or NIL directory component, return the (parsed) pathname.
+Otherwise return NIL"
+ (and pathspec
+ (typep pathspec '(or null pathname string))
+ (let* ((pathname (pathname pathspec))
+ (directory (normalize-pathname-directory-component
+ (pathname-directory pathname))))
+ (when (or (null directory) (eq :relative (car directory)))
+ pathname))))
+
(defun* hidden-pathname-p (pathname)
+ "Return a boolean that is true if the pathname is hidden as per Unix style,
+i.e. its name starts with a dot."
(and pathname (equal (first-char (pathname-name pathname)) #\.)))
(check-one (pathname-type pathname))
t)))))
+(defun* file-pathname-p (pathname)
+ "Does PATHNAME represent a file, i.e. has a non-null NAME component?
+
+Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME.
+
+Note that this does _not_ check to see that PATHNAME points to an
+actually-existing file.
+
+Returns the (parsed) PATHNAME when true"
+ (when pathname
+ (let* ((pathname (pathname pathname))
+ (name (pathname-name pathname)))
+ (when (not (member name '(nil :unspecific "") :test 'equal))
+ pathname))))
+
(defun* ensure-directory-pathname (pathspec)
"Converts the non-wild pathname designator PATHSPEC to directory form."
(cond
;;; Parsing filenames and lists thereof
(defun* split-unix-namestring-directory-components
- (unix-style-namestring &key want-directory dot-dot)
- "Splits the path string UNIX-STYLE-NAMESTRING, returning four values:
+ (unix-namestring &key ensure-directory dot-dot)
+ "Splits the path string UNIX-NAMESTRING, returning four values:
A flag that is either :absolute or :relative, indicating
how the rest of the values are to be interpreted.
A directory path --- a list of strings and keywords, suitable for
or NIL in the case of a directory pathname.
A flag that is true iff the unix-style-pathname was just
a file-namestring without / path specification.
-WANT-DIRECTORY forces the namestring to be interpreted as a directory pathname:
+ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname:
the third return value will be NIL, and final component of the namestring
will be treated as part of the directory path.
The intention of this function is to support structured component names,
e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
- (check-type unix-style-namestring string)
+ (check-type unix-namestring string)
(check-type dot-dot (member nil :back :up))
- (if (and (not (find #\/ unix-style-namestring)) (not want-directory)
- (plusp (length unix-style-namestring)))
- (values :relative () unix-style-namestring t)
- (let* ((components (split-string unix-style-namestring :separator "/"))
+ (if (and (not (find #\/ unix-namestring)) (not ensure-directory)
+ (plusp (length unix-namestring)))
+ (values :relative () unix-namestring t)
+ (let* ((components (split-string unix-namestring :separator "/"))
(last-comp (car (last components))))
(multiple-value-bind (relative components)
(if (equal (first components) "")
- (if (equal (first-char unix-style-namestring) #\/)
+ (if (equal (first-char unix-namestring) #\/)
(values :absolute (cdr components))
(values :relative nil))
(values :relative components))
(cond
((equal last-comp "")
(values relative components nil nil)) ; "" already removed from components
- (want-directory
+ (ensure-directory
(values relative components nil nil))
(t
(values relative (butlast components) last-comp nil)))))))
(values filename *unspecific-pathname-type*)
(values name type))))
-(defun* parse-unix-namestring (name &rest keys &key type defaults dot-dot want-directory
+(defun* parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory
&allow-other-keys)
"Coerce NAME into a PATHNAME using standard Unix syntax.
#\\/ separates directory components.
The last #\\/-separated substring is interpreted as follows:
-if TYPE is NIL, the substring is file-namestring, and its NAME and TYPE
-are separated by SPLIT-NAME-TYPE.
-if TYPE is a string, it is the given TYPE, and the whole string is the NAME;
-if TYPE is :DIRECTORY, the string is made the last directory component,
-and NAME and TYPE are NIL.
-if the string is empty, it's the empty pathname with all slots NIL.
+1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true,
+ the string is made the last directory component, and NAME and TYPE are NIL.
+ if the string is empty, it's the empty pathname with all slots NIL.
+2- If TYPE is NIL, the substring is file-namestring, and its NAME and TYPE
+ are separated by SPLIT-NAME-TYPE.
+3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
Directory components with an empty name the name . are removed.
-Any directory named .. is read as DOT-DOT, which defaults to :BACK (not :UP).
+Any directory named .. is read as DOT-DOT,
+which must be one of :BACK or :UP and defaults to :BACK.
HOST, DEVICE and VERSION components are taken from DEFAULTS,
-which itself defaults to (ROOT-PATHNAME).
+which itself defaults to (ROOT-PATHNAME), also used if DEFAULTS in NIL.
No host or device can be specified in the string itself,
-which might make it unsuitable for absolute pathnames on Windows.
+which makes it unsuitable for absolute pathnames outside Unix.
-For relative pathnames, these defaults won't matter if you use MERGE-PATHNAMES*
-but will matter if you use MERGE-PATHNAMES (which you shouldn't).
+For relative pathnames, these components (and hence the defaults) won't matter
+if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES,
+which is an important reason to always use MERGE-PATHNAMES*.
-Arbitrary keys are accepted, that are finally passed to ENSURE-PATHNAME,
-removing TYPE DEFAULTS and DOT-DOT.
-we recommend you use :WANT-RELATIVE T to throw an error if the pathname is absolute
-when you're running portable code and the OS may not be Unixish."
+Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME
+with those keys, removing TYPE DEFAULTS and DOT-DOT.
+When you're manipulating pathnames that are supposed to make sense portably
+even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T
+to throw an error if the pathname is absolute"
(block nil
(check-type type (or null string (eql :directory)))
- (setf want-directory (or want-directory (eq type :directory)))
+ (when (eq type :directory)
+ (setf ensure-directory t))
(etypecase name
((or null pathname) (return name))
(symbol
(string))
(multiple-value-bind (relative path filename file-only)
(split-unix-namestring-directory-components
- name :dot-dot dot-dot :want-directory want-directory)
+ name :dot-dot dot-dot :ensure-directory ensure-directory)
(multiple-value-bind (name type)
(cond
- ((or want-directory (null filename))
+ ((or ensure-directory (null filename))
(values nil nil))
(type
(values filename type))
(eql x separator)))
root-namestring)))
(multiple-value-bind (relative path filename)
- (split-unix-namestring-directory-components root-string :want-directory t)
+ (split-unix-namestring-directory-components root-string :ensure-directory t)
(declare (ignore relative filename))
(let ((new-base
(make-pathname* :defaults root :directory `(:absolute ,@path))))
;;; Check pathname constraints
(defun* ensure-pathname
- (pathname &key want-pathname want-existing
- want-absolute want-relative
+ (pathname &key
+ error-arguments
+ defaults type dot-dot
+ want-pathname
want-logical want-physical ensure-physical
- want-wild want-non-wild wilden
- ensure-directory want-directory want-file
- want-truename truenamize error-arguments)
- "Coerces its argument into a PATHNAME, and checks specified constraints.
+ 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
+ ensure-truename 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-NAMESTRING.
+
+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 ERROR-ARGUMENTS arguments, if provided,
will be passed on to the error primitive, together with three arguments:
-a string describing the error, that should be followed by a space and
-the pathname to report the error, the keyword that corresponds to that
-constraint name, and the pathname;
-this makes it usable whether you are using the short or long variants of ERROR,
-modulo your error object having to recognize the suitable keyword argument
-in case you use the long variant."
+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 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.
+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)
- (let ((err (append (or error-arguments '("Invalid pathname: ~A~* ~S"))
- (list description keyword pathname))))
+ (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))))))
- (macrolet ((err (constraint format)
- `(report-error ,constraint ',(intern* constraint :keyword) ,format)))
- (etypecase pathname
- (null
- (when want-pathname
- (err want-pathname "Expected a pathname, got"))
- (return nil))
+ (macrolet ((err (constraint &rest arguments)
+ `(report-error ,constraint ',(intern* constraint :keyword) ,@arguments))
+ (check (constraint condition &rest arguments)
+ `(when ,constraint
+ (unless ,condition (err ,constraint ,@arguments))))
+ (transform (flag condition expr)
+ `(when ,flag
+ (,@(if condition `(when ,condition) '(progn))
+ (setf p ,expr)))))
+ (etypecase p
+ ((or null pathname))
(string
- (setf pathname (parse-namestring pathname)))
- (pathname))
- (when want-logical
- (unless (typep pathname 'logical-pathname)
- (err want-logical "Expected a logical pathname, got")))
- (when want-physical
- (unless (physical-pathname-p pathname)
- (err want-physical "Expected a physical pathname, got")))
- (when ensure-physical
- (setf pathname (translate-logical-pathname pathname)))
- (when want-absolute
- (unless (absolute-pathname-p pathname)
- (err want-absolute "Expected an absolute pathname, got")))
- (when want-relative
- (when (absolute-pathname-p pathname)
- (err want-relative "Expected a relative pathname, got")))
- (when want-wild
- (unless (wild-pathname-p pathname)
- (err want-wild "Expected a wildcard pathname, got")))
- (when (or want-non-wild want-existing)
- (when (wild-pathname-p pathname)
- (err want-non-wild "Expected a non-wildcard pathname, got")))
- (when (and wilden (not (wild-pathname-p pathname)))
- (setf pathname (wilden pathname)))
- (when ensure-directory
- (setf pathname (ensure-directory-pathname pathname)))
- (when want-directory
- (unless (directory-pathname-p pathname)
- (err want-directory "Expected a directory pathname, got")))
- (when want-file
- (unless (pathname-name pathname)
- (err want-file "Expected a file pathname, got")))
+ (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 pathname (return NIL))
+ (check want-logical (typep p 'logical-pathname) "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))
+ (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 (not (absolute-pathname-p (enough-namestring 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* pathname)))
+ (let ((existing (probe-file* p)))
(if existing
- (when (or want-truename truenamize)
+ (when (or ensure-truename truenamize)
(return existing))
- (err want-existing "Expected an existing pathname, got"))))
- (when want-truename
- (let ((truename (truename* pathname)))
+ (err want-existing "Expected an existing pathname"))))
+ (when ensure-directories-exist (ensure-directories-exist p))
+ (when ensure-truename
+ (let ((truename (truename* p)))
(if truename
(return truename)
- (err want-truename "Can't get a truename for pathname"))))
- (when truenamize
- (return (truenamize pathname)))
- pathname))))
+ (err truename "Can't get a truename for pathname"))))
+ (transform truenamize () (truenamize p))
+ p))))
;;; Hook for output translations
(defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
(let ((plan (apply 'make-instance
(or plan-class 'sequential-plan)
- :system (component-system c) (remove-keyword :plan-class keys))))
+ :system (component-system c) (remove-key :plan-class keys))))
(traverse-action plan o c t)
(plan-actions plan)))
(defmethod slurp-input-stream ((x (eql :forms)) stream &key &allow-other-keys)
(declare (ignorable x))
- (slurp-stream-forms stream))
+ (slurp-stream-form stream :path nil))
(defmethod slurp-input-stream (x stream &key (element-type 'character) &allow-other-keys)
(declare (ignorable stream element-type))
((:directory)
(destructuring-bind (pathname) rest
(when pathname
- (funcall register (resolve-location pathname :want-directory t)))))
+ (funcall register (resolve-location pathname :ensure-directory t)))))
((:tree)
(destructuring-bind (pathname) rest
(when pathname
- (funcall register (resolve-location pathname :want-directory t)
+ (funcall register (resolve-location pathname :ensure-directory t)
:recurse t :exclude *source-registry-exclusions*))))
((:exclude)
(setf *source-registry-exclusions* rest))
(defun* sysdef-source-registry-search (system)
(ensure-source-registry)
- (values (gethash (coerce-name system) *source-registry*)))
+ (values (gethash (primary-system-name system) *source-registry*)))
#:with-output #:output-string #:with-input
#:with-input-file #:call-with-input-file
#:finish-outputs #:format! #:safe-format!
- #:read-file-forms #:read-first-file-form
#:copy-stream-to-stream #:concatenate-files
#:copy-stream-to-stream-line-by-line
- #:slurp-stream-string #:slurp-stream-lines
- #:slurp-stream-forms #:read-file-string
- #:read-file-lines #:read-file-forms
- #:safe-read-first-file-form #:eval-input #:eval-thunk #:standard-eval-thunk
+ #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-forms #:slurp-stream-form
+ #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form
+ #:eval-input #:eval-thunk #:standard-eval-thunk
#:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
#:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
#:*default-encoding* #:*utf-8-external-format*))
`(call-with-input ,value #'(lambda (,input-var) ,@body)))
(defun* call-with-input-file (pathname thunk
- &key (element-type *default-stream-element-type*)
- (external-format :default))
- "Open FILE for input with given options, call THUNK with the resulting stream."
+ &key
+ (element-type *default-stream-element-type*)
+ (external-format :default)
+ (if-does-not-exist :error))
+ "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
+Other keys are accepted but discarded."
#+gcl<2.7 (declare (ignore external-format))
(with-open-file (s pathname :direction :input
:element-type element-type
#-gcl<2.7 :external-format #-gcl<2.7 external-format
- :if-does-not-exist :error)
+ :if-does-not-exist if-does-not-exist)
(funcall thunk s)))
(defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body)
(with-open-stream (input input)
(loop :for l = (read-line input nil nil) :while l :collect l)))
-(defun* slurp-stream-forms (input)
- "Read the contents of the INPUT stream as a list of forms.
+(defun* slurp-stream-forms (input &key count)
+"Read the contents of the INPUT stream as a list of forms,
+and return those forms.
+
+If COUNT is null, read to the end of the stream;
+if COUNT is an integer, stop after COUNT forms were read.
+
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
- (with-open-stream (input input)
- (loop :with eof = '#:eof
- :for form = (read input nil eof)
- :until (eq form eof) :collect form)))
+ (check-type count (or null integer))
+ (loop :with eof = '#:eof
+ :for n :from 0
+ :for form = (if (and count (>= n count))
+ eof
+ (read-preserving-whitespace input nil eof))
+ :until (eq form eof) :collect form))
+
+(defun* slurp-stream-form (input &key (path 0))
+"Read the contents of the INPUT stream as a list of forms,
+then return the SUB-OBJECT of these forms following the PATH.
+PATH defaults to 0, i.e. return the first form.
+PATH is typically a list of integers.
+If PATH is NIL, it will return all the forms in the file.
+
+The stream will not be read beyond the Nth form,
+where N is the index specified by path,
+if path is either an integer or a list that starts with an integer.
+
+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
+ (let* ((count (cond
+ ((integerp path)
+ (1+ path))
+ ((and (consp path) (integerp (first path)))
+ (1+ (first path)))))
+ (forms (slurp-stream-forms input :count count)))
+ (sub-object forms path)))
(defun* read-file-string (file &rest keys)
"Open FILE with option KEYS, read its contents as a string"
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
(apply 'call-with-input-file file 'slurp-stream-lines keys))
-(defun* read-file-forms (file &rest keys)
- "Open FILE with option KEYS, read its contents as a list of forms.
+(defun* read-file-forms (file &rest keys &key count &allow-other-keys)
+ "Open input FILE with option KEYS (except COUNT),
+and read its contents as per SLURP-STREAM-FORMS with given COUNT.
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
- (apply 'call-with-input-file file 'slurp-stream-forms keys))
+ (apply 'call-with-input-file file
+ #'(lambda (input) (slurp-stream-forms input :count count))
+ (remove-key :count keys)))
-(defun* read-first-file-form (pathname &key eof-error-p eof-value)
- "Reads the first form from the top of a file.
+(defun* read-file-form (file &rest keys &key (path 0) &allow-other-keys)
+ "Open input FILE with option KEYS (except path),
+and read its contents as per SLURP-STREAM-FORM with given PATH.
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
- (with-input-file (in pathname)
- (read-preserving-whitespace in eof-error-p eof-value)))
-
-(defun* safe-read-first-file-form (pathname &key
- (package :cl)
- eof-error-p eof-value)
- "Reads the first form from the top of a file using a safe standardized syntax"
+ (apply 'call-with-input-file file
+ #'(lambda (input) (slurp-stream-form input :path path))
+ (remove-key :path keys)))
+
+(defun* safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys)
+ "Reads the specified form from the top of a file using a safe standardized syntax.
+Extracts the form using READ-FILE-FORM,
+within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
(with-safe-io-syntax (:package package)
- (read-first-file-form pathname :eof-error-p eof-error-p :eof-value eof-value)))
+ (apply 'read-file-form pathname (remove-key :package keys))))
(defun* eval-input (input)
"Portably read and evaluate forms from INPUT, return the last values."
(:intern #:children #:children-by-name #:default-component-class
#:author #:maintainer #:licence #:source-file #:defsystem-depends-on)
(:export
- #:child-component #:parent-component #:module #:system #:proto-system
- #:component-children-by-name #:component-children #:compute-children-by-name
- #:module-default-component-class
+ #:system #:proto-system
#:system-source-file #:system-source-directory #:system-relative-pathname
#:reset-system #:builtin-system-p
#:system-description #:system-long-description
#:system-author #:system-maintainer #:system-licence #:system-license
- #:find-system #:probe-asd ;; forward-reference, methods defined in find-system
- #:%set-system-source-file ;; For internal use only. DO NOT USE.
- #:module-components ;; backward-compatibility. DO NOT USE.
+ #:find-system ;; forward-reference, defined in find-system
#:system-defsystem-depends-on))
(in-package :asdf/system)
(defgeneric* find-system (system &optional error-p))
-(declaim (ftype (function (t t) t) probe-asd))
-
-;;;; Component hierarchy within a system
-;; The tree typically but not necessarily follows the filesystem hierarchy.
-
-(defclass child-component (component) ())
-
-(defclass parent-component (component)
- ((children
- :initform nil
- :initarg :components
- :reader module-components ; backward-compatibility
- :accessor component-children)
- (children-by-name
- :reader module-components-by-name ; backward-compatibility
- :accessor component-children-by-name)
- (default-component-class
- :initform nil
- :initarg :default-component-class
- :accessor module-default-component-class)))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun* compute-children-by-name (parent &key only-if-needed-p)
- (unless (and only-if-needed-p (slot-boundp parent 'children-by-name))
- (let ((hash (make-hash-table :test 'equal)))
- (setf (component-children-by-name parent) hash)
- (loop :for c :in (component-children parent)
- :for name = (component-name c)
- :for previous = (gethash name hash)
- :do (when previous (error 'duplicate-names :name name))
- (setf (gethash name hash) c))
- hash))))
-
-(when-upgrade (:when (find-class 'module nil))
- (defmethod reinitialize-instance :after ((m module) &rest initargs &key)
- (declare (ignorable m initargs)) (values))
- (defmethod update-instance-for-redefined-class :after
- ((m module) added deleted plist &key)
- (declare (ignorable m added deleted plist))
- (when (and (member 'children added) (member 'components deleted))
- (setf (slot-value m 'children)
- ;; old ECLs provide an alist instead of a plist(!)
- (if (or #+ecl (consp (first plist))) (or #+ecl (cdr (assoc 'components plist)))
- (getf plist 'components)))
- (compute-children-by-name m))
- (when (typep m 'system)
- (when (member 'source-file added)
- (%set-system-source-file
- (probe-asd (component-name m) (component-pathname m)) m))
- (when (equal (component-name m) "asdf")
- (setf (component-version m) (asdf-version))))))
-
-(defclass module (child-component parent-component)
- ())
-
+(defgeneric* system-source-file (system)
+ (:documentation "Return the source file in which system is defined."))
-;;;; The system class itself
+;;;; The system class
(defclass proto-system () ; slots to keep when resetting a system
;; To preserve identity for all objects, we'd need keep the components slots
(maintainer :accessor system-maintainer :initarg :maintainer)
(licence :accessor system-licence :initarg :licence
:accessor system-license :initarg :license)
- (source-file :initarg :source-file :writer %set-system-source-file) ; upgrade issues on CLISP, CMUCL
+ (source-file :initform nil :initarg :source-file :accessor system-source-file)
(defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
(defun* reset-system (system &rest keys &key &allow-other-keys)
(slot-value system 'source-file))
(call-next-method)))
-(defgeneric* system-source-file (system)
- (:documentation "Return the source file in which system is defined."))
-(defmethod system-source-file ((system system))
- ;; might be missing when upgrading from ASDF 1 and u-i-f-r-c failed
- (unless (slot-boundp system 'source-file)
- (%set-system-source-file
- (probe-asd (component-name system) (component-pathname system)) system))
- (slot-value system 'source-file))
(defmethod system-source-file ((system-name string))
(system-source-file (find-system system-name)))
(defmethod system-source-file ((system-name symbol))
(system-source-file (find-system system-name)))
(defun* system-source-directory (system-designator)
- "Return a pathname object corresponding to the
-directory in which the system specification (.asd file) is
-located."
+ "Return a pathname object corresponding to the directory
+in which the system specification (.asd file) is located."
(pathname-directory-pathname (system-source-file system-designator)))
(defun* system-relative-pathname (system name &key type)
fi
ASDFDIR="$(cd $(dirname $0)/.. ; /bin/pwd)"
+
+## Make sure testing remains within the confines of this filesystem tree
export CL_SOURCE_REGISTRY="${ASDFDIR}"
export ASDF_OUTPUT_TRANSLATIONS="(:output-translations (\"${ASDFDIR}\" (\"${ASDFDIR}/build/fasls\" :implementation)) :ignore-inherited-configuration)"
+
command="$command $flags"
if [ -z "${DEBUG_ASDF_TEST}" ] ; then
command="$command $nodebug"
(defun touch-file (file &key (offset 0) timestamp)
(let ((timestamp (or timestamp (+ offset (get-universal-time)))))
(multiple-value-bind (sec min hr day month year) (decode-universal-time timestamp #+gcl<2.7 -5)
- (acall :run-shell-command
- "touch -t ~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D ~S"
- year month day hr min sec (namestring file))
+ (acall :run-program/
+ `("touch" "-t" ,(format nil "~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D"
+ year month day hr min sec)
+ ,(namestring file)))
(assert-equal (file-write-date file) timestamp))))
(defun hash-table->alist (table)
#:asdf-version #:*upgraded-p*
#:asdf-message #:*asdf-verbose* #:*verbose-out*
;; There will be no symbol left behind!
- #:o #:c #:dep-o #:dep-c #:intern*)
+ #:intern*)
(:import-from :asdf/package #:intern* #:find-symbol*))
(in-package :asdf/upgrade)
;; Note that this massive package destruction makes it impossible
;; to use asdf/driver on top of an old ASDF on these implementations
-#+(or clisp xcl)
(eval-when (:load-toplevel :compile-toplevel :execute)
+ #+(or clisp xcl)
(unless (let ((vs (find-symbol* 'version-satisfies :asdf nil))
(av (find-symbol* 'asdf-version :asdf nil)))
(and vs av (funcall vs (funcall av) "2.26.59")))
(if-bind (p (find-package :asdf))
- (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))))
+ (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))))
;;; Special magic to detect if this is an upgrade
;; "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.105")
+ (asdf-version "2.26.106")
(existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
#:asdf-debug #:load-asdf-debug-utility #:*asdf-debug-utility*
#:undefine-function #:undefine-functions #:defun* #:defgeneric* ;; (un)defining functions
#:if-bind ;; basic flow control
- #:while-collecting #:appendf #:length=n-p #:remove-keys #:remove-keyword ;; lists and plists
+ #:while-collecting #:appendf #:length=n-p #:remove-keys #:remove-key ;; lists and plists
#:emptyp ;; sequences
#:first-char #:last-char #:split-string ;; strings
#:string-prefix-p #:string-enclosed-p #:string-suffix-p
#:find-class* ;; CLOS
- #:stamp< #:stamp<= #:earlier-stamp #:stamps-earliest #:earliest-stamp ;; stamps
+ #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
+ #:earlier-stamp #:stamps-earliest #:earliest-stamp
#:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
#:list-to-hash-set ;; hash-table
- #:ensure-function #:call-function #:call-functions #:register-hook-function ;; functions
+ #:ensure-function #:sub-object ;; functions
+ #:call-function #:call-functions #:register-hook-function
#:match-condition-p #:match-any-condition-p ;; conditions
#:call-with-muffled-conditions #:with-muffled-conditions
#:load-string #:load-stream
((zerop i) (return (null l)))
((not (consp l)) (return nil)))))
-;;; Keyword argument lists
-(defun* remove-keys (key-names args)
- (loop :for (name val) :on args :by #'cddr
- :unless (member (symbol-name name) key-names
- :key #'symbol-name :test 'equal)
- :append (list name val)))
-
-(defun* remove-keyword (key args)
- (loop :for (k v) :on args :by #'cddr
+;;; remove a key from a plist, i.e. for keyword argument cleanup
+(defun* remove-key (key plist)
+ "Remove a single key from a plist"
+ (loop :for (k v) :on plist :by #'cddr
:unless (eq k key)
:append (list k v)))
+(defun* remove-keys (keys plist)
+ "Remove a list of keys from a plist"
+ (loop :for (k v) :on plist :by #'cddr
+ :unless (member k keys)
+ :append (list k v)))
+
+
;;; Sequences
(defun* emptyp (x)
"Predicate that is true for an empty sequence"
(or (null x) (and (vectorp x) (zerop (length x)))))
+
;;; Strings
(defun* first-char (s)
(null nil)
((eql t) t)
(real (< x y))))))
-;;(defun* stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y)))
-;;(defun* stamp*< (&rest list) (stamps< list))
+(defun* stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y)))
+(defun* stamp*< (&rest list) (stamps< list))
(defun* stamp<= (x y) (not (stamp< y x)))
(defun* earlier-stamp (x y) (if (stamp< x y) x y))
(defun* stamps-earliest (list) (reduce 'earlier-stamp list :initial-value t))
(dolist (x list h) (setf (gethash x h) t)))
-;;; Code execution
+;;; Function designators
(defun* ensure-function (fun &key (package :cl))
+ "Coerce the object FUN into a function.
+
+If FUN is a FUNCTION, return it.
+If the FUN is a non-sequence literal constant, return constantly that,
+i.e. for a boolean keyword character number or pathname.
+Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION.
+If FUN is a CONS, return the function that applies its CAR
+to the appended list of the rest of its CDR and the arguments.
+If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
+and EVAL that in a (FUNCTION ...) context."
(etypecase fun
+ (function fun)
((or boolean keyword character number pathname) (constantly fun))
((or function symbol) fun)
- (cons (eval `(function ,fun)))
+ (cons #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))
(string (eval `(function ,(with-standard-io-syntax
(let ((*package* (find-package package)))
(read-from-string fun))))))))
+(defun* sub-object (object path)
+ "Given an OBJECT and a PATH, list of successive accessors,
+call each accessor on the result of the previous calls.
+An accessor may be an integer, meaning a call to ELT,
+a function or symbol, meaning itself,
+or a list of a function and arguments, interpreted as per ENSURE-FUNCTION.
+As a degenerate case, the PATH may be an atom of a single such accessor
+instead of a list."
+ (flet ((access (object accessor)
+ (etypecase accessor
+ (integer (elt object path))
+ ((or function symbol) (funcall accessor object))
+ (cons (funcall (ensure-function accessor) object)))))
+ (if (listp path)
+ (dolist (accessor path object)
+ (setf object (access object accessor)))
+ (access object path))))
+
(defun* call-function (function-spec &rest arguments)
(apply (ensure-function function-spec) arguments))
;;; Version handling
-(defun* parse-version (string &optional on-error)
- "Parse a version string as a series of natural integers separated by dots.
-Return a (non-null) list of integers if the string is valid, NIL otherwise.
-If on-error is error, warn, or designates a function of compatible signature,
-the function is called with an explanation of what is wrong with the argument.
-NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3"
+(defun* unparse-version (version-list)
+ (format nil "~{~D~^.~}" version-list))
+
+(defun* parse-version (version-string &optional on-error)
+ "Parse a VERSION-STRING as a series of natural integers separated by dots.
+Return a (non-null) list of integers if the string is valid;
+otherwise return NIL.
+
+When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL,
+with format arguments explaining why the version is invalid.
+ON-ERROR is also called if the version is not canonical
+in that it doesn't print back to itself, but the list is returned anyway."
(block nil
- (unless (stringp string)
- (call-function on-error "~S: ~S is not a string" 'parse-version string)
+ (unless (stringp version-string)
+ (call-function on-error "~S: ~S is not a string" 'parse-version version-string)
(return))
- (unless (loop :for prev = nil :then c :for c :across string
+ (unless (loop :for prev = nil :then c :for c :across version-string
:always (or (digit-char-p c)
(and (eql c #\.) prev (not (eql prev #\.))))
:finally (return (and c (digit-char-p c))))
(call-function on-error "~S: ~S doesn't follow asdf version numbering convention"
- 'parse-version string)
+ 'parse-version version-string)
(return))
- (mapcar #'parse-integer (split-string string :separator "."))))
+ (let* ((version-list
+ (mapcar #'parse-integer (split-string version-string :separator ".")))
+ (normalized-version (unparse-version version-list)))
+ (unless (equal version-string normalized-version)
+ (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string))
+ version-list)))
-(defun* unparse-version (version-list)
- (format nil "~{~D~^.~}" version-list))
(defun* version-compatible-p (provided-version required-version)
"Is the provided version a compatible substitution for the required-version?
common-lisp.net / projects/asdf/asdf.git / commitdiff
