Commit 8dc84f46 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.137: be more eager in detecting non-portable pathname behaviour and erroring out.

ATTENTION: incompatible change to component-name-to-pathname-components
Also, have compile-file* heed a :output-file parameter.
parent 9fe85c18
Loading
Loading
Loading
Loading
+29 −18
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.136" (1+ (length "VERSION"))))
          (subseq "VERSION:2.137" (1+ (length "VERSION"))))
         (existing-asdf (fboundp 'find-system))
         (existing-version *asdf-version*)
         (already-there (equal asdf-version existing-version)))
@@ -534,7 +534,18 @@ Also, if either argument is NIL, then the other argument is returned unmodified.
  (let* ((specified (pathname specified))
         (defaults (pathname defaults))
         (directory (pathname-directory specified))
         #-(or sbcl cmu) (directory (if (stringp directory) `(:absolute ,directory) directory))
         (directory
          (cond
            #-(or sbcl cmu)
            ((stringp directory) `(:absolute ,directory) directory)
            #+gcl
            ((and (consp directory) (stringp (first directory)))
             `(:absolute ,@directory))
            ((or (null directory)
                 (and (consp directory) (member (first directory) '(:absolute :relative))))
             directory)
            (t
             (error "Unrecognized directory component ~S in pathname ~S" directory specified))))
         (name (or (pathname-name specified) (pathname-name defaults)))
         (type (or (pathname-type specified) (pathname-type defaults)))
         (version (or (pathname-version specified) (pathname-version defaults))))
@@ -543,7 +554,7 @@ Also, if either argument is NIL, then the other argument is returned unmodified.
             (unspecific-handler (p)
               (if (typep p 'logical-pathname) #'ununspecific #'identity)))
      (multiple-value-bind (host device directory unspecific-handler)
          (#-gcl ecase #+gcl case (first directory)
          (ecase (first directory)
            ((nil)
             (values (pathname-host defaults)
                     (pathname-device defaults)
@@ -560,13 +571,6 @@ Also, if either argument is NIL, then the other argument is returned unmodified.
                     (if (pathname-directory defaults)
                         (append (pathname-directory defaults) (cdr directory))
                         directory)
                     (unspecific-handler defaults)))
            #+gcl
            (t
             (assert (stringp (first directory)))
             (values (pathname-host defaults)
                     (pathname-device defaults)
                     (append (pathname-directory defaults) directory)
                     (unspecific-handler defaults))))
        (make-pathname :host host :device device :directory directory
                       :name (funcall unspecific-handler name)
@@ -621,7 +625,7 @@ starting the separation from the end, e.g. when called with arguments
          (values filename unspecific)
          (values name type)))))

(defun* component-name-to-pathname-components (s &optional force-directory)
(defun* component-name-to-pathname-components (s &key force-directory force-relative)
  "Splits the path string S, returning three values:
A flag that is either :absolute or :relative, indicating
   how the rest of the values are to be interpreted.
@@ -638,12 +642,17 @@ 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)
  (when (find #\: s)
    (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s))
  (let* ((components (split-string s :separator "/"))
         (last-comp (car (last components))))
    (multiple-value-bind (relative components)
        (if (equal (first components) "")
            (if (equal (first-char s) #\/)
                (values :absolute (cdr components))
                (progn
                  (when force-relative
                    (error "absolute pathname designator not allowed: ~S" s))
                  (values :absolute (cdr components)))
                (values :relative nil))
          (values :relative components))
      (setf components (remove "" components :test #'equal))
@@ -840,7 +849,7 @@ with given pathname and if it exists return its truename."
                                         (eql x separator)))
                         root-namestring)))
    (multiple-value-bind (relative path filename)
        (component-name-to-pathname-components root-string t)
        (component-name-to-pathname-components root-string :force-directory t)
      (declare (ignore relative filename))
      (let ((new-base
             (make-pathname :defaults root
@@ -1371,7 +1380,8 @@ Going forward, we recommend new users should be using the source-registry.
     (merge-component-name-type (string-downcase name) :type type :defaults defaults))
    (string
     (multiple-value-bind (relative path filename)
         (component-name-to-pathname-components name (eq type :directory))
         (component-name-to-pathname-components name :force-directory (eq type :directory)
                                                :force-relative t)
       (multiple-value-bind (name type)
           (cond
             ((or (eq type :directory) (null filename))
@@ -2873,7 +2883,7 @@ with a different configuration, so the configuration would be re-read then."
    ;; These are for convenience, and can be overridden by the user:
    #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
    #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
    ;; If we want to enable the user cache by default, here would be the place:
    ;; We enable the user cache by default, and here is the place we do:
    :enable-user-cache))

(defparameter *output-translations-file* #p"asdf-output-translations.conf")
@@ -3052,8 +3062,8 @@ effectively disabling the output translation facility."
  (when (and x (probe-file x))
    (delete-file x)))

(defun* compile-file* (input-file &rest keys &key &allow-other-keys)
  (let* ((output-file (apply 'compile-file-pathname* input-file keys))
(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
  (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
         (tmp-file (tmpize-pathname output-file))
         (status :error))
    (multiple-value-bind (output-truename warnings-p failure-p)
@@ -3103,7 +3113,8 @@ effectively disabling the output translation facility."
     (include-per-user-information nil)
     (map-all-source-files (or #+(or ecl clisp) t nil))
     (source-to-target-mappings nil))
  (when (and (null map-all-source-files) #-(or ecl clisp) nil)
  #+(or ecl clisp)
  (when (null map-all-source-files)
    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
         (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
+1 −1
Original line number Diff line number Diff line
@@ -3417,7 +3417,7 @@ but that's all.
The defsystem 4 proposal tends to look more at the external features,
whereas this one centres on a protocol for system introspection.

@section kmp's ``The Description of Large Systems'', MIT AI Memu 801
@section kmp's ``The Description of Large Systems'', MIT AI Memo 801

Available in updated-for-CL form on the web at
@url{http://nhplace.com/kent/Papers/Large-Systems.html}
+11 −9
Original line number Diff line number Diff line
@@ -32,7 +32,8 @@

(defun test-component-pathnames (&key (root (asdf::pathname-directory-pathname *asdf-fasl*))
                                 (delete-host t)
                                 (support-string-pathnames nil))
                                 (support-string-pathnames nil)
                                 (support-absolute-string-pathnames nil))
  (unwind-protect
    (let* ((bin-type (pathname-type (compile-file-pathname "test.lisp")))
           (root-directory-namestring (format nil "~{/~a~}/" (rest (pathname-directory root))))
@@ -84,12 +85,12 @@
                                 "module2/"
                                 "module2/module3"
                                 "module2/module3/"
                                 ,(concatenate 'string root-directory-namestring "asdf-src/system1/module1")
                                 ,@(when support-absolute-string-pathnames
                                     `(,(concatenate 'string root-directory-namestring "asdf-src/system1/module1")
                                       ,(concatenate 'string root-directory-namestring "asdf-src/system1/module1/")
                                       ,(concatenate 'string root-directory-namestring "asdf-src/system1/module2/")
                                       ,(concatenate 'string root-directory-namestring "asdf-src/system1/module2/module3/")
                                 ,(concatenate 'string root-directory-namestring "asdf-src/system2/module4/")))))

                                       ,(concatenate 'string root-directory-namestring "asdf-src/system2/module4/")))))))
                (files `(nil
                         ,(make-pathname :directory '(:relative) :name "untyped-file" :type nil)
                         "file"
@@ -177,9 +178,10 @@
                                                                              (:static-file "static-file.type" :pathname ,file-pathname)
                                                                              (:file "module2/typed-file.type" :pathname ,file-pathname)
                                                                              (:static-file "module2/static-file.type" :pathname ,file-pathname)
                                                                              (:static-file ,(concatenate 'string root-directory-namestring
                                                                              ,@(when support-absolute-string-pathnames
                                                                                      `((:static-file ,(concatenate 'string root-directory-namestring
                                                                                                          "asdf-src/system1/module1/file.lisp")
                                                                                            :pathname ,file-pathname)))))))))
                                                                                            :pathname ,file-pathname)))))))))))

                    (block :test-system
                      (handler-bind
+6 −6
Original line number Diff line number Diff line
@@ -24,17 +24,17 @@
;; These are funky and non portable. Omit from tests.
;; (make-pathname :name "." :type nil :directory '(:absolute "tmp"))
;; (make-pathname :name "." :type "" :directory '(:absolute "tmp"))
(assert (equal (multiple-value-list (component-name-to-pathname-components "" t))
(assert (equal (multiple-value-list (component-name-to-pathname-components "" :force-directory t))
               '(:relative nil nil)))
(assert (equal (multiple-value-list (component-name-to-pathname-components "" nil))
(assert (equal (multiple-value-list (component-name-to-pathname-components ""  :force-directory nil))
               '(:relative nil nil)))
(assert (equal (multiple-value-list (component-name-to-pathname-components "/" t))
(assert (equal (multiple-value-list (component-name-to-pathname-components "/" :force-directory t))
               '(:absolute nil nil)))
(assert (equal (multiple-value-list (component-name-to-pathname-components "/" nil))
(assert (equal (multiple-value-list (component-name-to-pathname-components "/" :force-directory nil))
               '(:absolute nil nil)))
(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" t))
(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" :force-directory t))
               '(:absolute ("aa" "ba") nil)))
(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" nil))
(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" :force-directory nil))
               '(:absolute ("aa") "ba")))
(assert
 (asdf::version-satisfies (asdf:asdf-version) (asdf:asdf-version)))