From b45e9d68bf4fa2aa0bba77c83934afcf4b520caa Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Mon, 22 Feb 2010 11:57:38 -0500
Subject: [PATCH] Portably interpret string arguments to :pathname
 specifications.

---
 asdf.lisp                                  | 19 ++++++----
 asdf.texinfo                               | 40 ++++++++++++++--------
 test/test-retry-loading-component-1.script | 14 ++++----
 test/test-utilities.script                 | 12 +++++++
 4 files changed, 57 insertions(+), 28 deletions(-)

diff --git a/asdf.lisp b/asdf.lisp
index ea149edb..cb2100a2 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -484,7 +484,9 @@ pathnames."
          (last-comp (car (last components))))
     (multiple-value-bind (relative components)
         (if (equal (first components) "")
-          (values :absolute (cdr components))
+            (if (and (plusp (length s)) (eql (char s 0) #\/))
+                (values :absolute (cdr components))
+                (values :relative nil))
           (values :relative components))
       (cond
         ((equal last-comp "")
@@ -786,12 +788,15 @@ actually-existing directory."
        (truename *default-pathname-defaults*)))
 
 (defmethod component-relative-pathname ((component module))
-  (or (slot-value component 'relative-pathname)
-      (multiple-value-bind (relative path)
-          (component-name-to-pathname-components (component-name component) t)
-        (make-pathname
-         :directory `(,relative ,@path)
-         :host (pathname-host (component-parent-pathname component))))))
+  (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)
diff --git a/asdf.texinfo b/asdf.texinfo
index 34d059c3..cb84f2c3 100644
--- a/asdf.texinfo
+++ b/asdf.texinfo
@@ -455,7 +455,7 @@ option := :components component-list
         | :default-component-class
         | :perform method-form
         | :explain method-form
-        | :output-files  method-form
+        | :output-files method-form
         | :operation-done-p method-form
         | :depends-on ( {dependency-def}* )
         | :serial [ t | nil ]
@@ -1397,24 +1397,25 @@ ASDF bugs are tracked on launchpad: @url{https://launchpad.net/asdf}.
 
 @item ``I want to put my module's files at the top level.  How do I do this?''
 
-By default, the files contained in an asdf module go in a subdirectory
-with the same name as the module.  However, this can be overridden by
-adding a @code{:pathname} argument to the module description.  For
-example, here is how it is done in the spatial-trees ASDF system
-definition:
+By default, the files contained in an asdf module go
+in a subdirectory with the same name as the module.
+However, this can be overridden by adding a @code{:pathname} argument
+to the module description.
+For example, here is how it is done
+in the spatial-trees ASDF system definition:
 
 @example
 (asdf:defsystem :spatial-trees
   :components
   ((:module base
-            :pathname #.(make-pathname :directory '(:relative))
+            :pathname ""
             :components
             ((:file "package")
              (:file "basedefs" :depends-on ("package"))
              (:file "rectangles" :depends-on ("package"))))
    (:module tree-impls
             :depends-on (base)
-            :pathname #.(make-pathname :directory '(:relative))
+            :pathname ""
             :components
             ((:file "r-trees")
              (:file "greene-trees" :depends-on ("r-trees"))
@@ -1423,20 +1424,31 @@ definition:
              (:file "x-trees" :depends-on ("r-trees" "rstar-trees"))))
    (:module viz
             :depends-on (base)
-            :pathname #.(make-pathname :directory '(:relative))
+            :pathname ""
             :components
-            ((:static-file "spatial-tree-viz"
-                           :pathname #p"spatial-tree-viz.lisp")))
+            ((:static-file "spatial-tree-viz.lisp")))
    (:module tests
             :depends-on (base)
-            :pathname #.(make-pathname :directory '(:relative))
+            :pathname ""
             :components
-            ((:static-file "spatial-tree-test"
-                           :pathname #p"spatial-tree-test.lisp")))
+            ((:static-file "spatial-tree-test.lisp")))
    (:static-file "LICENCE")
    (:static-file "TODO")))
 @end example
 
+Note that the argument to @code{:pathname} can be either a pathname object or a string.
+A pathname object can be constructed with the @code{#p"foo/bar/"} syntax,
+but this is discouraged because the results are not portable.
+It can only be portably constructed with such syntax as
+@code{#.(make-pathname :directory '(:relative "foo" "bar"))},
+and similarly the current directory can only be portably specified as
+@code{#.(make-pathname :directory '(:relative "foo" "bar"))}.
+As of ASDF 1.623, however, you can portably use a string,
+which will be parsed as a @code{/}-separated path from the current directory,
+such that the empty string @code{""} denotes the current directory, and
+@code{"foo/bar"} (no trailing @code{/} required in the case of modules)
+portably denotes the same subdirectory as above.
+
 All of the files in the @code{tree-impls} module are at the top level,
 instead of in a @code{tree-impls/} subdirectory.
 
diff --git a/test/test-retry-loading-component-1.script b/test/test-retry-loading-component-1.script
index 7495f747..d0d0e228 100644
--- a/test/test-retry-loading-component-1.script
+++ b/test/test-retry-loading-component-1.script
@@ -10,29 +10,29 @@
 ;(trace excl.osi:command-output)
 (defvar *caught-error* nil)
 (quit-on-error
- (format t "trlc1 1~%")
+ ;;(format t "trlc1 1~%")
  (when (probe-file "try-reloading-dependency.asd")
    (asdf:run-shell-command "rm -f ~A"
                            (namestring "try-reloading-dependency.asd")))
  (setf asdf:*central-registry* '(*default-pathname-defaults*))
  (setf asdf::*defined-systems* (asdf::make-defined-systems-table))
- (format t "trlc1 2~%")
+ ;;(format t "trlc1 2~%")
  (handler-bind ((error (lambda (c)
                          (format t "~&Caught error ~s" c)
                          (setf *caught-error* t)
                          (asdf:run-shell-command
                           "cp try-reloading-dependency.hidden try-reloading-dependency.asd")
-                         (format t "trlc1 5~%")
+                         ;;(format t "trlc1 5~%")
                          (multiple-value-bind (name mode)
                              (find-symbol (symbol-name 'retry) :asdf)
                            (assert (eq mode :external) nil "Mode of ~s was not external" name)
-                           (format t "trlc1 6~%")
+                           ;;(format t "trlc1 6~%")
                            (let ((restart (find-restart name c)))
-                             (format t "trlc1 7~%")
+                             ;;(format t "trlc1 7~%")
                              (assert restart)
                              (format t "~&restart: ~S~&" restart)
                              (when restart (invoke-restart restart)))))))
-   (format t "trlc1 3~%")
+   ;;(format t "trlc1 3~%")
    (asdf:oos 'asdf:load-op 'try-reloading-1))
- (format t "trlc1 4~%")
+ ;;(format t "trlc1 4~%")
  (assert *caught-error*))
diff --git a/test/test-utilities.script b/test/test-utilities.script
index a7216d5d..9475d2b1 100644
--- a/test/test-utilities.script
+++ b/test/test-utilities.script
@@ -23,6 +23,18 @@
    (make-pathname :name nil :type "bar" :directory '(:absolute "tmp"))
    (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))
+               '(:relative nil nil)))
+(assert (equal (multiple-value-list (component-name-to-pathname-components "" nil))
+               '(:relative nil nil)))
+(assert (equal (multiple-value-list (component-name-to-pathname-components "/" t))
+               '(:absolute nil nil)))
+(assert (equal (multiple-value-list (component-name-to-pathname-components "/" nil))
+               '(:absolute nil nil)))
+(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" t))
+               '(:absolute ("aa" "ba") nil)))
+(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" nil))
+               '(:absolute ("aa") "ba")))
 (assert
  (asdf::version-satisfies (asdf:asdf-version) (asdf:asdf-version)))
 (assert
-- 
GitLab