Commit 927e8770 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.132: enable pathname designator DSL for source-registry.

Also, allow for upgradability from old ASDF versions that don't have system-source-file.
parent 713dbc5e
Loading
Loading
Loading
Loading
+58 −39
Original line number Diff line number Diff line
@@ -72,7 +72,7 @@
  (defvar *asdf-version* nil)
  (defvar *upgraded-p* nil)
  (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
          (subseq "VERSION:2.131" (1+ (length "VERSION"))))
          (subseq "VERSION:2.132" (1+ (length "VERSION"))))
         (existing-asdf (fboundp 'find-system))
         (existing-version *asdf-version*)
         (already-there (equal asdf-version existing-version)))
@@ -178,7 +178,7 @@
           (#:perform #:explain #:output-files #:operation-done-p
            #:perform-with-restarts #:component-relative-pathname
            #:system-source-file #:operate #:find-component #:find-system
            #:apply-output-translations #:translate-pathname*)
            #:apply-output-translations #:translate-pathname* #:resolve-location)
           :unintern
           (#:*asdf-revision* #:around #:asdf-method-combination
            #:split #:make-collector)
@@ -323,12 +323,19 @@
         (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
   (when (find-class 'module nil)
     (eval
      '(defmethod update-instance-for-redefined-class :after
      '(progn
         (defmethod update-instance-for-redefined-class :after
             ((m module) added deleted plist &key)
           (declare (ignorable deleted plist))
           (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m))
           (when (member 'components-by-name added)
           (compute-module-components-by-name m))))))
             (compute-module-components-by-name m)))
         (defmethod update-instance-for-redefined-class :after
             ((s system) added deleted plist &key)
           (declare (ignorable deleted plist))
           (when *asdf-verbose* (format *trace-output* "Updating ~A~%" s))
           (when (member 'source-file added)
             (%set-system-source-file (probe-asd (component-name s) (component-pathname s)) s)))))))

;;;; -------------------------------------------------------------------------
;;;; User-visible parameters
@@ -2683,19 +2690,24 @@ with a different configuration, so the configuration would be re-read then."
  (make-pathname :directory '(:relative :wild-inferiors)
                 :name :wild :type "asd" :version :newest))

(declaim (ftype (function (t &optional boolean) (values (or null pathname) &optional))
(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
                          (values (or null pathname) &optional))
                resolve-location))

(defun* resolve-relative-location-component (super x &optional wildenp)
(defun* resolve-relative-location-component (super x &key directory wilden)
  (let* ((r (etypecase x
              (pathname x)
              (string x)
              (cons
               (let ((car (resolve-relative-location-component super (car x) nil)))
               (return-from resolve-relative-location-component
                 (if (null (cdr x))
                     car
                     (let ((cdr (resolve-relative-location-component
                                 (merge-pathnames* car super) (cdr x) wildenp)))
                     (resolve-relative-location-component
                      super (car x) :directory directory :wilden wilden)
                     (let* ((car (resolve-relative-location-component
                                  super (car x) :directory t :wilden nil))
                            (cdr (resolve-relative-location-component
                                  (merge-pathnames* car super) (cdr x)
                                  :directory directory :wilden wilden)))
                       (merge-pathnames* cdr car)))))
              ((eql :default-directory)
               (relativize-pathname-directory (default-directory)))
@@ -2703,49 +2715,55 @@ with a different configuration, so the configuration would be re-read then."
              ((eql :implementation-type) (string-downcase (implementation-type)))
              #-(and (or win32 windows mswindows mingw32) (not cygwin))
              ((eql :uid) (princ-to-string (get-uid)))))
         (d (if (pathnamep x) r (ensure-directory-pathname r)))
         (s (if (and wildenp (not (pathnamep x)))
                (wilden d)
                d)))
         (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
         (s (if (or (pathnamep x) (not wilden)) d (wilden 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)))

(defun* resolve-absolute-location-component (x wildenp)
(defun* resolve-absolute-location-component (x &key directory wilden)
  (let* ((r
          (etypecase x
            (pathname x)
            (string (ensure-directory-pathname x))
            (string (if directory (ensure-directory-pathname x) (parse-namestring x)))
            (cons
             (let ((car (resolve-absolute-location-component (car x) nil)))
             (return-from resolve-absolute-location-component
               (if (null (cdr x))
                   car
                   (let ((cdr (resolve-relative-location-component
                               car (cdr x) wildenp)))
                     (merge-pathnames* cdr car)))))
                   (resolve-absolute-location-component
                    (car x) :directory directory :wilden wilden)
                   (let* ((car (resolve-absolute-location-component
                                (car x) :directory t :wilden nil))
                          (cdr (resolve-relative-location-component
                                car (cdr x) :directory directory :wilden wilden)))
                     (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?
            ((eql :root)
             ;; special magic! we encode such paths as relative pathnames,
             ;; but it means "relative to the root of the source pathname's host and device".
             (return-from resolve-absolute-location-component
               (make-pathname :directory '(:relative))))
               (let ((p (make-pathname :directory '(:relative))))
                 (if wilden (wilden p) p))))
            ((eql :home) (user-homedir))
            ((eql :user-cache) (resolve-location *user-cache* nil))
            ((eql :system-cache) (resolve-location *system-cache* nil))
            ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
            ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
            ((eql :default-directory) (default-directory))))
         (s (if (and wildenp (not (pathnamep x)))
         (s (if (and wilden (not (pathnamep x)))
                (wilden r)
                r)))
    (unless (absolute-pathname-p s)
      (error "Not an absolute pathname ~S" s))
    s))

(defun* resolve-location (x &optional wildenp)
(defun* resolve-location (x &key directory wilden)
  (if (atom x)
      (resolve-absolute-location-component x wildenp)
      (loop :with path = (resolve-absolute-location-component (car x) nil)
      (resolve-absolute-location-component x :directory directory :wilden wilden)
      (loop :with path = (resolve-absolute-location-component
                          (car x) :directory (and (or directory (cdr x)) t)
                          :wilden (and wilden (null (cdr x))))
        :for (component . morep) :on (cdr x)
        :for dir = (and (or morep directory) t)
        :for wild = (and wilden (not morep))
        :do (setf path (resolve-relative-location-component
                        path component (and wildenp (not morep))))
                        path component :directory dir :wilden wild))
        :finally (return path))))

(defun* location-designator-p (x)
@@ -2920,7 +2938,7 @@ with a different configuration, so the configuration would be re-read then."
              (process-output-translations (pathname dst) :inherit nil :collect collect))
            (when src
              (let ((trusrc (or (eql src t)
                                (let ((loc (resolve-location src t)))
                                (let ((loc (resolve-location src :directory t :wilden t)))
                                  (if (absolute-pathname-p loc) (truenamize loc) loc)))))
                (cond
                  ((location-function-p dst)
@@ -2933,7 +2951,7 @@ with a different configuration, so the configuration would be re-read then."
                   (funcall collect (list trusrc t)))
                  (t
                   (let* ((trudst (make-pathname
                                   :defaults (if dst (resolve-location dst t) trusrc)))
                                   :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
                          (wilddst (make-pathname
                                    :name :wild :type :wild :version :wild
                                    :defaults trudst)))
@@ -3218,7 +3236,7 @@ with a different configuration, so the configuration would be re-read then."
            (case kw
              ((:include :directory :tree)
               (and (length=n-p rest 1)
                    (typep (car rest) '(or pathname string null))))
                    (location-designator-p (first rest))))
              ((:exclude :also-exclude)
               (every #'stringp rest))
              (null rest))))
@@ -3382,15 +3400,16 @@ with a different configuration, so the configuration would be re-read then."
    (ecase kw
      ((:include)
       (destructuring-bind (pathname) rest
         (process-source-registry (pathname pathname) :inherit nil :register register)))
         (process-source-registry (resolve-location pathname) :inherit nil :register register)))
      ((:directory)
       (destructuring-bind (pathname) rest
         (when pathname
           (funcall register (ensure-directory-pathname pathname)))))
           (funcall register (resolve-location pathname :directory t)))))
      ((:tree)
       (destructuring-bind (pathname) rest
         (when pathname
           (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*))))
           (funcall register (resolve-location pathname :directory t)
                    :recurse t :exclude *source-registry-exclusions*))))
      ((:exclude)
       (setf *source-registry-exclusions* rest))
      ((:also-exclude)
+24 −1
Original line number Diff line number Diff line
@@ -1752,6 +1752,29 @@ DIRECTIVE :=
    ;; This directive specifies that some default must be spliced.
    :default-registry

REGULAR-FILE-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a file
DIRECTORY-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a directory name

PATHNAME-DESIGNATOR :=
    NULL | ;; Special: skip this entry.
    ABSOLUTE-COMPONENT-DESIGNATOR |
    (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...)

ABSOLUTE-COMPONENT-DESIGNATOR :=
    STRING | ;; namestring (better be absolute or bust, directory assumed where applicable)
    PATHNAME | ;; pathname (better be an absolute path, or bust)
    :HOME | ;; designates the user-homedir-pathname ~/
    :USER-CACHE | ;; designates the default location for the user cache
    :SYSTEM-CACHE ;; designates the default location for the system cache

RELATIVE-COMPONENT-DESIGNATOR :=
    STRING | ;; namestring (directory assumed where applicable)
    PATHNAME | ;; pathname
    :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64
    :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
    :UID | ;; current UID -- not available on Windows
    :USER ;; current USER name -- NOT IMPLEMENTED(!)

PATTERN := a string without wildcards, that will be matched exactly
	against the name of a any subdirectory in the directory component
        of a path. e.g. @code{"_darcs"} will match @file{#p"/foo/bar/_darcs/src/bar.asd"}
@@ -1762,7 +1785,7 @@ which is the default place ASDF looks for this configuration,
once contained:
@example
(:source-registry
  (:tree "/home/fare/cl/")
  (:tree (:home "cl")) ;; will expand to e.g. "/home/joeluser/cl/"
  :inherit-configuration)
@end example

+9 −0
Original line number Diff line number Diff line
@@ -278,6 +278,15 @@
 (asdf:initialize-output-translations)
 (format t "output translations: ~S~%" (asdf::output-translations))

 #-(or clisp ecl) ; clisp has problem with the first one having :version :newest
 (progn ; 1- we're testing with unix, are we not?
   (assert (equal (asdf::resolve-location '(:home)) (truename (user-homedir-pathname))))
   (assert (equal (asdf::resolve-location '("/foo" "bar" "baz")) #p"/foo/bar/baz"))
   (assert (equal (asdf::resolve-location '("/foo" "bar" "baz") :directory t) #p"/foo/bar/baz/"))
   (assert (equal (asdf::resolve-location '("/foo" "bar" "baz") :directory t :wilden t) (asdf::wilden #p"/foo/bar/baz/")))
   (assert (equal (asdf::resolve-location '("/foo" "bar" "baz") :directory nil :wilden t) (asdf::wilden #p"/foo/bar/")))
   (assert (equal (asdf::resolve-location '("/foo" "bar" #p"**/" "baz" #p"*.*") :directory nil :wilden t) #p"/foo/bar/**/baz/*.*")))

 (or (test-component-pathnames :delete-host t :support-string-pathnames nil)
     (leave-lisp "test failed" 1)))

+1 −0
Original line number Diff line number Diff line
@@ -21,6 +21,7 @@
           (compile-file *asdf-lisp* :output-file tmp :print t :verbose t))
       (declare (ignore result))
       (cond
         #-ecl ; 10.7.1 has spurious warnings. Sigh.
         (warnings-p
          (leave-lisp "Testsuite failed: ASDF compiled with warnings" 1))
         (errors-p
+4 −0
Original line number Diff line number Diff line
@@ -2,3 +2,7 @@
(in-package :test-package)
(defvar *file-tmp* t)

(eval-when (:compile-toplevel :execute)
  (format t "compiling level1/file1~%"))
(eval-when (:load-toplevel :execute)
  (format t "loading level1/file1~%"))
Loading