Loading asdf.lisp +157 −102 Original line number Diff line number Diff line Loading @@ -49,7 +49,7 @@ (cl:in-package :cl-user) (declaim (optimize (speed 3) (debug 2) (safety 2))) (declaim (optimize (speed 2) (debug 2) (safety 3))) #+ecl (require 'cmp) Loading Loading @@ -111,6 +111,7 @@ ':asdf-utilities :nicknames '(#:asdf-extensions) :use '(#:common-lisp) :unintern '(#:make-collector) :export '(#:absolute-pathname-p #:aif Loading @@ -123,7 +124,7 @@ #:getenv #:get-uid #:length=n-p #:make-collector #:merge-pathnames* #:pathname-directory-pathname #:pathname-sans-name+type ;; deprecated. Use pathname-directory-pathname #:read-file-forms Loading @@ -132,8 +133,10 @@ #:resolve-symlinks #:split #:component-name-to-pathname-components #:split-name-type #:system-registered-p #:truenamize)) #:truenamize #:while-collecting)) (ensure-package ':asdf :use '(:common-lisp :asdf-utilities) Loading Loading @@ -244,7 +247,7 @@ ;; This parameter isn't actually user-visible ;; -- please use the exported function ASDF:ASDF-VERSION below. ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace (subseq "VERSION:1.627" (1+ (length "VERSION")))) (subseq "VERSION:1.628" (1+ (length "VERSION")))) (defun asdf-version () "Exported interface to the version of ASDF currently installed. A string. Loading Loading @@ -462,6 +465,14 @@ structure will mirror that of the source.")) ;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities (defmacro while-collecting ((&rest collectors) &body body) (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) (initial-values (mapcar (constantly nil) collectors))) `(let ,(mapcar #'list vars initial-values) (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v))) collectors vars) ,@body (values ,@(mapcar #'(lambda (v) `(nreverse ,v)) vars)))))) (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) Loading @@ -478,6 +489,33 @@ Deprecated. Use PATHNAME-DIRECTORY-PATHNAME instead." and NIL NAME, TYPE and VERSION components" (make-pathname :name nil :type nil :version nil :defaults 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 come from the DEFAULTS." (let* ((specified (pathname specified)) (defaults (pathname defaults)) (directory (pathname-directory specified)) (directory (if (stringp directory) `(:absolute ,directory) directory)) (name (or (pathname-name specified) (pathname-name defaults))) (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) (multiple-value-bind (host device directory) (ecase (first directory) ((nil) (values (pathname-host defaults) (pathname-device defaults) (pathname-directory defaults))) ((:absolute) (values (pathname-host specified) (pathname-device specified) directory)) ((:relative) (values (pathname-host defaults) (pathname-device defaults) (append (pathname-directory defaults) (cdr directory))))) (make-pathname :host host :device device :directory directory :name name :type type :version version)))) (define-modify-macro appendf (&rest args) append "Append onto list") Loading @@ -485,19 +523,33 @@ and NIL NAME, TYPE and VERSION components" (declare (dynamic-extent format-args)) (apply #'format *verbose-out* format-string format-args)) ;;; with apologies to Christophe Rhodes ... (defun split (string &optional max (ws '(#\Space #\Tab))) (flet ((is-ws (char) (find char ws))) (nreverse (let ((list nil) (start 0) (words 0) end) (defun split (string &key max (separator '(#\Space #\Tab))) ;; Beware: this API function has changed in ASDF 1.628! ;; optional arguments became keyword arguments, and max now works from the end. "Split STRING in components separater by any of the characters in the sequence SEPARATOR, return a list. If MAX is specified, then no more than max(1,MAX) components will be returned, starting the separation from the end, e.g. when called with arguments \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." (let ((list nil) (words 0) (end (length string))) (flet ((separatorp (char) (find char separator)) (done () (return-from split (cons (subseq string 0 end) list)))) (loop (when (and max (>= words (1- max))) (return (cons (subseq string start) list))) (setf end (position-if #'is-ws string :start start)) (push (subseq string start end) list) :for start = (if (and max (>= words (1- max))) (done) (position-if #'separatorp string :end end :from-end t)) :do (when (null start) (done)) (push (subseq string (1+ start) end) list) (incf words) (unless end (return list)) (setf start (1+ end))))))) (setf end start))))) (defun split-name-type (filename) (destructuring-bind (name &optional type) (split filename :max 2 :separator ".") (if (equal name "") (values filename nil) (values name type)))) (defun component-name-to-pathname-components (s &optional force-directory) "Splits the path string S, returning three values: Loading @@ -516,7 +568,7 @@ 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 s string) (let* ((components (split s nil "/")) (let* ((components (split s :separator "/")) (last-comp (car (last components)))) (multiple-value-bind (relative components) (if (equal (first components) "") Loading Loading @@ -625,11 +677,6 @@ actually-existing directory." (and (<= 0 start) (string-equal s suffix :start1 start)))) (defun make-collector () (let ((acc ())) (values (lambda (x) (push x acc)) (lambda () (reverse acc))))) (defun read-file-forms (file) (with-open-file (in file) (loop :with eof = (list nil) Loading @@ -656,36 +703,36 @@ actually-existing directory." (defun truenamize (p) "Resolve as much of a pathname as possible" (block :t (setf p (translate-logical-pathname (merge-pathnames p))) (ignore-errors (return-from :t (truename p))) (block nil (when (typep p 'logical-pathname) (return p)) (ignore-errors (return (truename p))) (let ((host (pathname-host p)) (device (pathname-device p)) (directory (pathname-directory p))) (when (or (atom directory) (not (eq :absolute (car directory)))) (return-from :t p)) (return p)) (let ((sofar (ignore-errors (truename (make-pathname :host host :device device :directory '(:absolute)))))) (unless sofar (return-from :t p)) (unless sofar (return p)) (loop :for component :in (cdr directory) :for rest :on (cdr directory) :for more = (ignore-errors (truename (merge-pathnames (merge-pathnames* (make-pathname :directory `(:relative ,component)) sofar))) :do (if more (setf sofar more) (return-from :t (merge-pathnames (return (merge-pathnames* (make-pathname :host nil :device nil :directory `(:relative ,@rest) :defaults p) sofar))) :finally (return-from :t (merge-pathnames (return (merge-pathnames* (make-pathname :host nil :device nil :directory nil :defaults p) Loading Loading @@ -823,19 +870,8 @@ actually-existing directory." (component-pathname it) (truename *default-pathname-defaults*))) (defmethod component-relative-pathname ((component module)) (let ((specified-pathname (or (slot-value component 'relative-pathname) (component-name component)))) (if (pathnamep specified-pathname) specified-pathname (multiple-value-bind (relative path) (component-name-to-pathname-components specified-pathname t) (make-pathname :directory `(,relative ,@path) :host (pathname-host (component-parent-pathname component))))))) (defmethod component-pathname ((component component)) (merge-pathnames (component-relative-pathname component) (merge-pathnames* (component-relative-pathname component) (component-parent-pathname component))) (defmethod component-property ((c component) property) Loading Loading @@ -869,9 +905,9 @@ actually-existing directory." (defmethod version-satisfies ((cver string) version) (let ((x (mapcar #'parse-integer (split cver nil '(#\.)))) (split cver :separator "."))) (y (mapcar #'parse-integer (split version nil '(#\.))))) (split version :separator ".")))) (labels ((bigger (x y) (cond ((not y) t) ((not x) nil) Loading Loading @@ -920,7 +956,7 @@ called with an object of type asdf:system." ;;; convention that functions in this list are prefixed SYSDEF- (defparameter *system-definition-search-functions* '(sysdef-central-registry-search)) '(sysdef-central-registry-search sysdef-source-registry-search)) (defun system-definition-pathname (system) (let ((system-name (coerce-name system))) Loading Loading @@ -1082,31 +1118,47 @@ to `~a` which is not a directory.~@:>" (defclass doc-file (static-file) ()) (defclass html-file (doc-file) ()) (defmethod source-file-type ((component module) (s module)) :directory) (defmethod source-file-type ((c cl-source-file) (s module)) "lisp") (defmethod source-file-type ((c c-source-file) (s module)) "c") (defmethod source-file-type ((c java-source-file) (s module)) "java") (defmethod source-file-type ((c html-file) (s module)) "html") (defmethod source-file-type ((c static-file) (s module)) nil) (defun merge-component-relative-pathname (pathname name type) (defun merge-component-relative-pathname (name &key type defaults) ;; The defaults are required notably because they provide the default host ;; to the below make-pathname, which may crucially matter to ;; e.g. people somehow using logical-pathnames. (etypecase name (pathname name) (symbol (merge-component-relative-pathname (string-downcase name) :type type :defaults defaults)) (string (multiple-value-bind (relative path filename) (component-name-to-pathname-components name) (merge-pathnames (or pathname (make-pathname :directory `(,relative ,@path))) (if type (make-pathname :name filename :type type) filename)))) (defmethod component-relative-pathname ((component source-file)) ;; This binding of *default-pathname-defaults* is required notably because ;; it will provide the default host to the above make-pathname, which may ;; crucially matter to e.g. people somehow using logical-pathnames. (let ((*default-pathname-defaults* (component-pathname (component-parent component)))) (component-name-to-pathname-components name (eq type :directory)) (multiple-value-bind (name type) (cond ((or (eq type :directory) (null filename)) (values nil nil)) (type (values filename type)) (t (split-name-type filename))) (let* ((defaults (pathname (or defaults *default-pathname-defaults*))) (host (pathname-host defaults)) (device (pathname-device defaults))) (make-pathname :directory `(,relative ,@path) :name name :type type :host host :device device))))))) (defmethod component-relative-pathname ((component component)) (merge-component-relative-pathname (slot-value component 'relative-pathname) (component-name component) (source-file-type component (component-system component))))) (or (slot-value component 'relative-pathname) (component-name component)) :type (source-file-type component (component-system component)) :defaults (let ((parent (component-parent component))) (and parent (component-pathname parent))))) ;;;; ------------------------------------------------------------------------- ;;;; Operations Loading Loading @@ -2048,7 +2100,7 @@ output to `*verbose-out*`. Returns the shell's exit code." (defun system-relative-pathname (system pathname &key name type) (let ((directory (pathname-directory pathname))) (merge-pathnames (merge-pathnames* (make-pathname :name (or name (pathname-name pathname)) :type (or type (pathname-type pathname)) :directory (relativize-directory directory)) Loading Loading @@ -2181,9 +2233,7 @@ output to `*verbose-out*`. Returns the shell's exit code." (defun validate-configuration-directory (directory tag validator) (let ((files (sort (ignore-errors (directory (merge-pathnames (make-pathname :name :wild :type :wild) directory) (directory (make-pathname :name :wild :type :wild :defaults directory) #+sbcl :resolve-symlinks #+sbcl nil)) #'string< :key #'namestring))) `(,tag Loading Loading @@ -2231,8 +2281,12 @@ with a different configuration, so the configuration would be re-read then." (make-pathname :directory '(:relative :wild-inferiors) :name :wild :type :wild :version nil)) (defparameter *wild-asd* (make-pathname :directory '(:relative :wild-inferiors) :name :wild :type "asd" :version nil)) (defun wilden (path) (merge-pathnames *wild-path* path)) (merge-pathnames* *wild-path* path)) (defun resolve-absolute-location-component (x wildenp) (let* ((r Loading Loading @@ -2267,7 +2321,7 @@ with a different configuration, so the configuration would be re-read then." d))) (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super)))) (error "pathname ~S is not relative to ~S" s super)) (merge-pathnames s super))) (merge-pathnames* s super))) (defun resolve-location (x &optional wildenp) (if (atom x) Loading Loading @@ -2376,13 +2430,13 @@ with a different configuration, so the configuration would be re-read then." (defparameter *output-translations-directory* #p"common-lisp/asdf-output-translations.conf.d/") (defun user-output-translations-pathname () (merge-pathnames *output-translations-file* (user-configuration-directory))) (merge-pathnames* *output-translations-file* (user-configuration-directory))) (defun system-output-translations-pathname () (merge-pathnames *output-translations-file* (system-configuration-directory))) (merge-pathnames* *output-translations-file* (system-configuration-directory))) (defun user-output-translations-directory-pathname () (merge-pathnames *output-translations-directory* (user-configuration-directory))) (merge-pathnames* *output-translations-directory* (user-configuration-directory))) (defun system-output-translations-directory-pathname () (merge-pathnames *output-translations-directory* (system-configuration-directory))) (merge-pathnames* *output-translations-directory* (system-configuration-directory))) (defun environment-output-translations () (getenv "ASDF_OUTPUT_TRANSLATIONS")) Loading Loading @@ -2416,13 +2470,8 @@ with a different configuration, so the configuration would be re-read then." (defmethod process-output-translations ((form cons) &key (inherit *default-output-translations*) collect) (multiple-value-bind (collect result) (if collect (values collect (constantly nil)) (make-collector)) (dolist (directive (cdr (validate-output-translations-form form))) (process-output-translations-directive directive :inherit inherit :collect collect)) (funcall result))) (process-output-translations-directive directive :inherit inherit :collect collect))) (defun inherit-output-translations (inherit &key collect) (when inherit Loading @@ -2447,12 +2496,17 @@ with a different configuration, so the configuration would be re-read then." (trudst (if dst (resolve-location dst t) trusrc))) (funcall collect (list trusrc trudst))))))) ;; Will read the configuration and initialize all internal variables, ;; and return the new configuration. (defun compute-output-translations (&optional (translations *default-output-translations*)) "read the configuration, return it" (while-collecting (c) (inherit-output-translations translations :collect #'c))) (defun initialize-output-translations (&optional (translations *default-output-translations*)) (setf (output-translations) (inherit-output-translations translations))) "read the configuration, initialize the internal configuration variable, return the configuration" (setf (output-translations) (compute-output-translations translations))) ;; checks an initial variable to see whether the state is initialized ;; or cleared. In the former case, return current configuration; in Loading @@ -2464,12 +2518,16 @@ with a different configuration, so the configuration would be re-read then." (initialize-output-translations))) (defun apply-output-translations (path) (etypecase path (logical-pathname path) ((or pathname string) (ensure-output-translations) (setf path (truenamize path)) (loop :for (source destination) :in (car *output-translations*) :when (pathname-match-p path source) :return (translate-pathname path source destination) :finally (return path))) :finally (return path))))) (defmethod output-files :around ((op operation) (c component)) "Method to rewrite output files to fasl-root" Loading @@ -2478,7 +2536,7 @@ with a different configuration, so the configuration would be re-read then." (defun compile-file-pathname* (input-file &rest keys) (apply-output-translations (apply #'compile-file-pathname (truenamize (merge-pathnames (make-pathname :type "lisp") input-file)) (truenamize (make-pathname :type "lisp" :defaults input-file)) keys))) ;;;; ----------------------------------------------------------------- Loading Loading @@ -2559,8 +2617,6 @@ with a different configuration, so the configuration would be re-read then." ;;;; Source Registry Configuration, by Francois-Rene Rideau ;;;; See README.source-registry and https://bugs.launchpad.net/asdf/+bug/485918 (pushnew 'sysdef-source-registry-search *system-definition-search-functions*) ;; Using ack 1.2 exclusions (defvar *default-exclusions* '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst" Loading Loading @@ -2673,7 +2729,7 @@ with a different configuration, so the configuration would be re-read then." (if (not recurse) (funcall collect (ensure-directory-pathname directory)) (let* ((files (ignore-errors (directory (merge-pathnames #P"**/*.asd" directory) (directory (merge-pathnames* *wild-asd* directory) #+sbcl #+sbcl :resolve-symlinks nil #+clisp #+clisp :circle t))) (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files) Loading Loading @@ -2774,7 +2830,7 @@ with a different configuration, so the configuration would be re-read then." ;; Will read the configuration and initialize all internal variables, ;; and return the new configuration. (defun compute-source-registry (&optional parameter) (multiple-value-bind (collect result) (make-collector) (while-collecting (collect) (inherit-source-registry `(wrapping-source-registry ,parameter Loading @@ -2784,8 +2840,7 @@ with a different configuration, so the configuration would be re-read then." (lambda (directory &key recurse exclude) (register-asd-directory directory :recurse recurse :exclude exclude :collect collect))) (funcall result))) :recurse recurse :exclude exclude :collect #'collect))))) (defun initialize-source-registry (&optional parameter) (setf (source-registry) (compute-source-registry parameter))) Loading test/script-support.lisp +7 −3 Original line number Diff line number Diff line Loading @@ -41,8 +41,12 @@ is bound, write a message and exit on an error. If (handler-bind ((error (lambda (c) (format *error-output* "~a" c) (if (ignore-errors (funcall (find-symbol "GETENV" :asdf) "DEBUG_ASDF_TEST")) (break) (leave-lisp "~&Script failed~%" 1))))) (cond ((ignore-errors (funcall (find-symbol "GETENV" :asdf) "DEBUG_ASDF_TEST")) (break)) (t #+sbcl (sb-debug:backtrace 69) #+clozure (ccl:print-call-history :count 69 :start-frame-number 1) (leave-lisp "~&Script failed~%" 1)))))) (funcall thunk) (leave-lisp "~&Script succeeded~%" 0))) test/test1.script +5 −1 Original line number Diff line number Diff line Loading @@ -4,8 +4,12 @@ (quit-on-error (setf asdf:*central-registry* '(*default-pathname-defaults*)) (format t "blah ~S~%" asdf:*central-registry*) (describe (asdf:find-system 'test1)) (trace asdf:operate asdf:perform asdf::merge-component-relative-pathname asdf:component-name asdf:component-pathname) (asdf:operate 'asdf:load-op 'test1) (format t "blah~%") ;; test that it compiled (let* ((file1 (asdf:compile-file-pathname* "file1")) (file2 (asdf:compile-file-pathname* "file2")) Loading test/test2.asd +0 −2 Original line number Diff line number Diff line Loading @@ -4,5 +4,3 @@ :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")))) (:file "file1")) :depends-on (version 'test2a "1.1")) test/wild-module.asd +1 −1 Original line number Diff line number Diff line Loading @@ -2,4 +2,4 @@ (asdf:defsystem :wild-module :version "0.0" :components ((:wild-module "systems" :pathname "*.asd"))) :components ((:wild-module "systems" :pathname #p"*.asd"))) Loading
asdf.lisp +157 −102 Original line number Diff line number Diff line Loading @@ -49,7 +49,7 @@ (cl:in-package :cl-user) (declaim (optimize (speed 3) (debug 2) (safety 2))) (declaim (optimize (speed 2) (debug 2) (safety 3))) #+ecl (require 'cmp) Loading Loading @@ -111,6 +111,7 @@ ':asdf-utilities :nicknames '(#:asdf-extensions) :use '(#:common-lisp) :unintern '(#:make-collector) :export '(#:absolute-pathname-p #:aif Loading @@ -123,7 +124,7 @@ #:getenv #:get-uid #:length=n-p #:make-collector #:merge-pathnames* #:pathname-directory-pathname #:pathname-sans-name+type ;; deprecated. Use pathname-directory-pathname #:read-file-forms Loading @@ -132,8 +133,10 @@ #:resolve-symlinks #:split #:component-name-to-pathname-components #:split-name-type #:system-registered-p #:truenamize)) #:truenamize #:while-collecting)) (ensure-package ':asdf :use '(:common-lisp :asdf-utilities) Loading Loading @@ -244,7 +247,7 @@ ;; This parameter isn't actually user-visible ;; -- please use the exported function ASDF:ASDF-VERSION below. ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace (subseq "VERSION:1.627" (1+ (length "VERSION")))) (subseq "VERSION:1.628" (1+ (length "VERSION")))) (defun asdf-version () "Exported interface to the version of ASDF currently installed. A string. Loading Loading @@ -462,6 +465,14 @@ structure will mirror that of the source.")) ;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities (defmacro while-collecting ((&rest collectors) &body body) (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) (initial-values (mapcar (constantly nil) collectors))) `(let ,(mapcar #'list vars initial-values) (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v))) collectors vars) ,@body (values ,@(mapcar #'(lambda (v) `(nreverse ,v)) vars)))))) (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) Loading @@ -478,6 +489,33 @@ Deprecated. Use PATHNAME-DIRECTORY-PATHNAME instead." and NIL NAME, TYPE and VERSION components" (make-pathname :name nil :type nil :version nil :defaults 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 come from the DEFAULTS." (let* ((specified (pathname specified)) (defaults (pathname defaults)) (directory (pathname-directory specified)) (directory (if (stringp directory) `(:absolute ,directory) directory)) (name (or (pathname-name specified) (pathname-name defaults))) (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) (multiple-value-bind (host device directory) (ecase (first directory) ((nil) (values (pathname-host defaults) (pathname-device defaults) (pathname-directory defaults))) ((:absolute) (values (pathname-host specified) (pathname-device specified) directory)) ((:relative) (values (pathname-host defaults) (pathname-device defaults) (append (pathname-directory defaults) (cdr directory))))) (make-pathname :host host :device device :directory directory :name name :type type :version version)))) (define-modify-macro appendf (&rest args) append "Append onto list") Loading @@ -485,19 +523,33 @@ and NIL NAME, TYPE and VERSION components" (declare (dynamic-extent format-args)) (apply #'format *verbose-out* format-string format-args)) ;;; with apologies to Christophe Rhodes ... (defun split (string &optional max (ws '(#\Space #\Tab))) (flet ((is-ws (char) (find char ws))) (nreverse (let ((list nil) (start 0) (words 0) end) (defun split (string &key max (separator '(#\Space #\Tab))) ;; Beware: this API function has changed in ASDF 1.628! ;; optional arguments became keyword arguments, and max now works from the end. "Split STRING in components separater by any of the characters in the sequence SEPARATOR, return a list. If MAX is specified, then no more than max(1,MAX) components will be returned, starting the separation from the end, e.g. when called with arguments \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." (let ((list nil) (words 0) (end (length string))) (flet ((separatorp (char) (find char separator)) (done () (return-from split (cons (subseq string 0 end) list)))) (loop (when (and max (>= words (1- max))) (return (cons (subseq string start) list))) (setf end (position-if #'is-ws string :start start)) (push (subseq string start end) list) :for start = (if (and max (>= words (1- max))) (done) (position-if #'separatorp string :end end :from-end t)) :do (when (null start) (done)) (push (subseq string (1+ start) end) list) (incf words) (unless end (return list)) (setf start (1+ end))))))) (setf end start))))) (defun split-name-type (filename) (destructuring-bind (name &optional type) (split filename :max 2 :separator ".") (if (equal name "") (values filename nil) (values name type)))) (defun component-name-to-pathname-components (s &optional force-directory) "Splits the path string S, returning three values: Loading @@ -516,7 +568,7 @@ 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 s string) (let* ((components (split s nil "/")) (let* ((components (split s :separator "/")) (last-comp (car (last components)))) (multiple-value-bind (relative components) (if (equal (first components) "") Loading Loading @@ -625,11 +677,6 @@ actually-existing directory." (and (<= 0 start) (string-equal s suffix :start1 start)))) (defun make-collector () (let ((acc ())) (values (lambda (x) (push x acc)) (lambda () (reverse acc))))) (defun read-file-forms (file) (with-open-file (in file) (loop :with eof = (list nil) Loading @@ -656,36 +703,36 @@ actually-existing directory." (defun truenamize (p) "Resolve as much of a pathname as possible" (block :t (setf p (translate-logical-pathname (merge-pathnames p))) (ignore-errors (return-from :t (truename p))) (block nil (when (typep p 'logical-pathname) (return p)) (ignore-errors (return (truename p))) (let ((host (pathname-host p)) (device (pathname-device p)) (directory (pathname-directory p))) (when (or (atom directory) (not (eq :absolute (car directory)))) (return-from :t p)) (return p)) (let ((sofar (ignore-errors (truename (make-pathname :host host :device device :directory '(:absolute)))))) (unless sofar (return-from :t p)) (unless sofar (return p)) (loop :for component :in (cdr directory) :for rest :on (cdr directory) :for more = (ignore-errors (truename (merge-pathnames (merge-pathnames* (make-pathname :directory `(:relative ,component)) sofar))) :do (if more (setf sofar more) (return-from :t (merge-pathnames (return (merge-pathnames* (make-pathname :host nil :device nil :directory `(:relative ,@rest) :defaults p) sofar))) :finally (return-from :t (merge-pathnames (return (merge-pathnames* (make-pathname :host nil :device nil :directory nil :defaults p) Loading Loading @@ -823,19 +870,8 @@ actually-existing directory." (component-pathname it) (truename *default-pathname-defaults*))) (defmethod component-relative-pathname ((component module)) (let ((specified-pathname (or (slot-value component 'relative-pathname) (component-name component)))) (if (pathnamep specified-pathname) specified-pathname (multiple-value-bind (relative path) (component-name-to-pathname-components specified-pathname t) (make-pathname :directory `(,relative ,@path) :host (pathname-host (component-parent-pathname component))))))) (defmethod component-pathname ((component component)) (merge-pathnames (component-relative-pathname component) (merge-pathnames* (component-relative-pathname component) (component-parent-pathname component))) (defmethod component-property ((c component) property) Loading Loading @@ -869,9 +905,9 @@ actually-existing directory." (defmethod version-satisfies ((cver string) version) (let ((x (mapcar #'parse-integer (split cver nil '(#\.)))) (split cver :separator "."))) (y (mapcar #'parse-integer (split version nil '(#\.))))) (split version :separator ".")))) (labels ((bigger (x y) (cond ((not y) t) ((not x) nil) Loading Loading @@ -920,7 +956,7 @@ called with an object of type asdf:system." ;;; convention that functions in this list are prefixed SYSDEF- (defparameter *system-definition-search-functions* '(sysdef-central-registry-search)) '(sysdef-central-registry-search sysdef-source-registry-search)) (defun system-definition-pathname (system) (let ((system-name (coerce-name system))) Loading Loading @@ -1082,31 +1118,47 @@ to `~a` which is not a directory.~@:>" (defclass doc-file (static-file) ()) (defclass html-file (doc-file) ()) (defmethod source-file-type ((component module) (s module)) :directory) (defmethod source-file-type ((c cl-source-file) (s module)) "lisp") (defmethod source-file-type ((c c-source-file) (s module)) "c") (defmethod source-file-type ((c java-source-file) (s module)) "java") (defmethod source-file-type ((c html-file) (s module)) "html") (defmethod source-file-type ((c static-file) (s module)) nil) (defun merge-component-relative-pathname (pathname name type) (defun merge-component-relative-pathname (name &key type defaults) ;; The defaults are required notably because they provide the default host ;; to the below make-pathname, which may crucially matter to ;; e.g. people somehow using logical-pathnames. (etypecase name (pathname name) (symbol (merge-component-relative-pathname (string-downcase name) :type type :defaults defaults)) (string (multiple-value-bind (relative path filename) (component-name-to-pathname-components name) (merge-pathnames (or pathname (make-pathname :directory `(,relative ,@path))) (if type (make-pathname :name filename :type type) filename)))) (defmethod component-relative-pathname ((component source-file)) ;; This binding of *default-pathname-defaults* is required notably because ;; it will provide the default host to the above make-pathname, which may ;; crucially matter to e.g. people somehow using logical-pathnames. (let ((*default-pathname-defaults* (component-pathname (component-parent component)))) (component-name-to-pathname-components name (eq type :directory)) (multiple-value-bind (name type) (cond ((or (eq type :directory) (null filename)) (values nil nil)) (type (values filename type)) (t (split-name-type filename))) (let* ((defaults (pathname (or defaults *default-pathname-defaults*))) (host (pathname-host defaults)) (device (pathname-device defaults))) (make-pathname :directory `(,relative ,@path) :name name :type type :host host :device device))))))) (defmethod component-relative-pathname ((component component)) (merge-component-relative-pathname (slot-value component 'relative-pathname) (component-name component) (source-file-type component (component-system component))))) (or (slot-value component 'relative-pathname) (component-name component)) :type (source-file-type component (component-system component)) :defaults (let ((parent (component-parent component))) (and parent (component-pathname parent))))) ;;;; ------------------------------------------------------------------------- ;;;; Operations Loading Loading @@ -2048,7 +2100,7 @@ output to `*verbose-out*`. Returns the shell's exit code." (defun system-relative-pathname (system pathname &key name type) (let ((directory (pathname-directory pathname))) (merge-pathnames (merge-pathnames* (make-pathname :name (or name (pathname-name pathname)) :type (or type (pathname-type pathname)) :directory (relativize-directory directory)) Loading Loading @@ -2181,9 +2233,7 @@ output to `*verbose-out*`. Returns the shell's exit code." (defun validate-configuration-directory (directory tag validator) (let ((files (sort (ignore-errors (directory (merge-pathnames (make-pathname :name :wild :type :wild) directory) (directory (make-pathname :name :wild :type :wild :defaults directory) #+sbcl :resolve-symlinks #+sbcl nil)) #'string< :key #'namestring))) `(,tag Loading Loading @@ -2231,8 +2281,12 @@ with a different configuration, so the configuration would be re-read then." (make-pathname :directory '(:relative :wild-inferiors) :name :wild :type :wild :version nil)) (defparameter *wild-asd* (make-pathname :directory '(:relative :wild-inferiors) :name :wild :type "asd" :version nil)) (defun wilden (path) (merge-pathnames *wild-path* path)) (merge-pathnames* *wild-path* path)) (defun resolve-absolute-location-component (x wildenp) (let* ((r Loading Loading @@ -2267,7 +2321,7 @@ with a different configuration, so the configuration would be re-read then." d))) (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super)))) (error "pathname ~S is not relative to ~S" s super)) (merge-pathnames s super))) (merge-pathnames* s super))) (defun resolve-location (x &optional wildenp) (if (atom x) Loading Loading @@ -2376,13 +2430,13 @@ with a different configuration, so the configuration would be re-read then." (defparameter *output-translations-directory* #p"common-lisp/asdf-output-translations.conf.d/") (defun user-output-translations-pathname () (merge-pathnames *output-translations-file* (user-configuration-directory))) (merge-pathnames* *output-translations-file* (user-configuration-directory))) (defun system-output-translations-pathname () (merge-pathnames *output-translations-file* (system-configuration-directory))) (merge-pathnames* *output-translations-file* (system-configuration-directory))) (defun user-output-translations-directory-pathname () (merge-pathnames *output-translations-directory* (user-configuration-directory))) (merge-pathnames* *output-translations-directory* (user-configuration-directory))) (defun system-output-translations-directory-pathname () (merge-pathnames *output-translations-directory* (system-configuration-directory))) (merge-pathnames* *output-translations-directory* (system-configuration-directory))) (defun environment-output-translations () (getenv "ASDF_OUTPUT_TRANSLATIONS")) Loading Loading @@ -2416,13 +2470,8 @@ with a different configuration, so the configuration would be re-read then." (defmethod process-output-translations ((form cons) &key (inherit *default-output-translations*) collect) (multiple-value-bind (collect result) (if collect (values collect (constantly nil)) (make-collector)) (dolist (directive (cdr (validate-output-translations-form form))) (process-output-translations-directive directive :inherit inherit :collect collect)) (funcall result))) (process-output-translations-directive directive :inherit inherit :collect collect))) (defun inherit-output-translations (inherit &key collect) (when inherit Loading @@ -2447,12 +2496,17 @@ with a different configuration, so the configuration would be re-read then." (trudst (if dst (resolve-location dst t) trusrc))) (funcall collect (list trusrc trudst))))))) ;; Will read the configuration and initialize all internal variables, ;; and return the new configuration. (defun compute-output-translations (&optional (translations *default-output-translations*)) "read the configuration, return it" (while-collecting (c) (inherit-output-translations translations :collect #'c))) (defun initialize-output-translations (&optional (translations *default-output-translations*)) (setf (output-translations) (inherit-output-translations translations))) "read the configuration, initialize the internal configuration variable, return the configuration" (setf (output-translations) (compute-output-translations translations))) ;; checks an initial variable to see whether the state is initialized ;; or cleared. In the former case, return current configuration; in Loading @@ -2464,12 +2518,16 @@ with a different configuration, so the configuration would be re-read then." (initialize-output-translations))) (defun apply-output-translations (path) (etypecase path (logical-pathname path) ((or pathname string) (ensure-output-translations) (setf path (truenamize path)) (loop :for (source destination) :in (car *output-translations*) :when (pathname-match-p path source) :return (translate-pathname path source destination) :finally (return path))) :finally (return path))))) (defmethod output-files :around ((op operation) (c component)) "Method to rewrite output files to fasl-root" Loading @@ -2478,7 +2536,7 @@ with a different configuration, so the configuration would be re-read then." (defun compile-file-pathname* (input-file &rest keys) (apply-output-translations (apply #'compile-file-pathname (truenamize (merge-pathnames (make-pathname :type "lisp") input-file)) (truenamize (make-pathname :type "lisp" :defaults input-file)) keys))) ;;;; ----------------------------------------------------------------- Loading Loading @@ -2559,8 +2617,6 @@ with a different configuration, so the configuration would be re-read then." ;;;; Source Registry Configuration, by Francois-Rene Rideau ;;;; See README.source-registry and https://bugs.launchpad.net/asdf/+bug/485918 (pushnew 'sysdef-source-registry-search *system-definition-search-functions*) ;; Using ack 1.2 exclusions (defvar *default-exclusions* '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst" Loading Loading @@ -2673,7 +2729,7 @@ with a different configuration, so the configuration would be re-read then." (if (not recurse) (funcall collect (ensure-directory-pathname directory)) (let* ((files (ignore-errors (directory (merge-pathnames #P"**/*.asd" directory) (directory (merge-pathnames* *wild-asd* directory) #+sbcl #+sbcl :resolve-symlinks nil #+clisp #+clisp :circle t))) (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files) Loading Loading @@ -2774,7 +2830,7 @@ with a different configuration, so the configuration would be re-read then." ;; Will read the configuration and initialize all internal variables, ;; and return the new configuration. (defun compute-source-registry (&optional parameter) (multiple-value-bind (collect result) (make-collector) (while-collecting (collect) (inherit-source-registry `(wrapping-source-registry ,parameter Loading @@ -2784,8 +2840,7 @@ with a different configuration, so the configuration would be re-read then." (lambda (directory &key recurse exclude) (register-asd-directory directory :recurse recurse :exclude exclude :collect collect))) (funcall result))) :recurse recurse :exclude exclude :collect #'collect))))) (defun initialize-source-registry (&optional parameter) (setf (source-registry) (compute-source-registry parameter))) Loading
test/script-support.lisp +7 −3 Original line number Diff line number Diff line Loading @@ -41,8 +41,12 @@ is bound, write a message and exit on an error. If (handler-bind ((error (lambda (c) (format *error-output* "~a" c) (if (ignore-errors (funcall (find-symbol "GETENV" :asdf) "DEBUG_ASDF_TEST")) (break) (leave-lisp "~&Script failed~%" 1))))) (cond ((ignore-errors (funcall (find-symbol "GETENV" :asdf) "DEBUG_ASDF_TEST")) (break)) (t #+sbcl (sb-debug:backtrace 69) #+clozure (ccl:print-call-history :count 69 :start-frame-number 1) (leave-lisp "~&Script failed~%" 1)))))) (funcall thunk) (leave-lisp "~&Script succeeded~%" 0)))
test/test1.script +5 −1 Original line number Diff line number Diff line Loading @@ -4,8 +4,12 @@ (quit-on-error (setf asdf:*central-registry* '(*default-pathname-defaults*)) (format t "blah ~S~%" asdf:*central-registry*) (describe (asdf:find-system 'test1)) (trace asdf:operate asdf:perform asdf::merge-component-relative-pathname asdf:component-name asdf:component-pathname) (asdf:operate 'asdf:load-op 'test1) (format t "blah~%") ;; test that it compiled (let* ((file1 (asdf:compile-file-pathname* "file1")) (file2 (asdf:compile-file-pathname* "file2")) Loading
test/test2.asd +0 −2 Original line number Diff line number Diff line Loading @@ -4,5 +4,3 @@ :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")))) (:file "file1")) :depends-on (version 'test2a "1.1"))
test/wild-module.asd +1 −1 Original line number Diff line number Diff line Loading @@ -2,4 +2,4 @@ (asdf:defsystem :wild-module :version "0.0" :components ((:wild-module "systems" :pathname "*.asd"))) :components ((:wild-module "systems" :pathname #p"*.asd")))