Skip to content
Snippets Groups Projects
Commit b45e9d68 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Portably interpret string arguments to :pathname specifications.

parent 7a55f292
No related branches found
No related tags found
No related merge requests found
...@@ -484,7 +484,9 @@ pathnames." ...@@ -484,7 +484,9 @@ pathnames."
(last-comp (car (last components)))) (last-comp (car (last components))))
(multiple-value-bind (relative components) (multiple-value-bind (relative components)
(if (equal (first 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)) (values :relative components))
(cond (cond
((equal last-comp "") ((equal last-comp "")
...@@ -786,12 +788,15 @@ actually-existing directory." ...@@ -786,12 +788,15 @@ actually-existing directory."
(truename *default-pathname-defaults*))) (truename *default-pathname-defaults*)))
(defmethod component-relative-pathname ((component module)) (defmethod component-relative-pathname ((component module))
(or (slot-value component 'relative-pathname) (let ((specified-pathname (or (slot-value component 'relative-pathname)
(multiple-value-bind (relative path) (component-name component))))
(component-name-to-pathname-components (component-name component) t) (if (pathnamep specified-pathname)
(make-pathname specified-pathname
:directory `(,relative ,@path) (multiple-value-bind (relative path)
:host (pathname-host (component-parent-pathname component)))))) (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)) (defmethod component-pathname ((component component))
(merge-pathnames (component-relative-pathname component) (merge-pathnames (component-relative-pathname component)
......
...@@ -455,7 +455,7 @@ option := :components component-list ...@@ -455,7 +455,7 @@ option := :components component-list
| :default-component-class | :default-component-class
| :perform method-form | :perform method-form
| :explain method-form | :explain method-form
| :output-files method-form | :output-files method-form
| :operation-done-p method-form | :operation-done-p method-form
| :depends-on ( {dependency-def}* ) | :depends-on ( {dependency-def}* )
| :serial [ t | nil ] | :serial [ t | nil ]
...@@ -1397,24 +1397,25 @@ ASDF bugs are tracked on launchpad: @url{https://launchpad.net/asdf}. ...@@ -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?'' @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 By default, the files contained in an asdf module go
with the same name as the module. However, this can be overridden by in a subdirectory with the same name as the module.
adding a @code{:pathname} argument to the module description. For However, this can be overridden by adding a @code{:pathname} argument
example, here is how it is done in the spatial-trees ASDF system to the module description.
definition: For example, here is how it is done
in the spatial-trees ASDF system definition:
@example @example
(asdf:defsystem :spatial-trees (asdf:defsystem :spatial-trees
:components :components
((:module base ((:module base
:pathname #.(make-pathname :directory '(:relative)) :pathname ""
:components :components
((:file "package") ((:file "package")
(:file "basedefs" :depends-on ("package")) (:file "basedefs" :depends-on ("package"))
(:file "rectangles" :depends-on ("package")))) (:file "rectangles" :depends-on ("package"))))
(:module tree-impls (:module tree-impls
:depends-on (base) :depends-on (base)
:pathname #.(make-pathname :directory '(:relative)) :pathname ""
:components :components
((:file "r-trees") ((:file "r-trees")
(:file "greene-trees" :depends-on ("r-trees")) (:file "greene-trees" :depends-on ("r-trees"))
...@@ -1423,20 +1424,31 @@ definition: ...@@ -1423,20 +1424,31 @@ definition:
(:file "x-trees" :depends-on ("r-trees" "rstar-trees")))) (:file "x-trees" :depends-on ("r-trees" "rstar-trees"))))
(:module viz (:module viz
:depends-on (base) :depends-on (base)
:pathname #.(make-pathname :directory '(:relative)) :pathname ""
:components :components
((:static-file "spatial-tree-viz" ((:static-file "spatial-tree-viz.lisp")))
:pathname #p"spatial-tree-viz.lisp")))
(:module tests (:module tests
:depends-on (base) :depends-on (base)
:pathname #.(make-pathname :directory '(:relative)) :pathname ""
:components :components
((:static-file "spatial-tree-test" ((:static-file "spatial-tree-test.lisp")))
:pathname #p"spatial-tree-test.lisp")))
(:static-file "LICENCE") (:static-file "LICENCE")
(:static-file "TODO"))) (:static-file "TODO")))
@end example @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, All of the files in the @code{tree-impls} module are at the top level,
instead of in a @code{tree-impls/} subdirectory. instead of in a @code{tree-impls/} subdirectory.
......
...@@ -10,29 +10,29 @@ ...@@ -10,29 +10,29 @@
;(trace excl.osi:command-output) ;(trace excl.osi:command-output)
(defvar *caught-error* nil) (defvar *caught-error* nil)
(quit-on-error (quit-on-error
(format t "trlc1 1~%") ;;(format t "trlc1 1~%")
(when (probe-file "try-reloading-dependency.asd") (when (probe-file "try-reloading-dependency.asd")
(asdf:run-shell-command "rm -f ~A" (asdf:run-shell-command "rm -f ~A"
(namestring "try-reloading-dependency.asd"))) (namestring "try-reloading-dependency.asd")))
(setf asdf:*central-registry* '(*default-pathname-defaults*)) (setf asdf:*central-registry* '(*default-pathname-defaults*))
(setf asdf::*defined-systems* (asdf::make-defined-systems-table)) (setf asdf::*defined-systems* (asdf::make-defined-systems-table))
(format t "trlc1 2~%") ;;(format t "trlc1 2~%")
(handler-bind ((error (lambda (c) (handler-bind ((error (lambda (c)
(format t "~&Caught error ~s" c) (format t "~&Caught error ~s" c)
(setf *caught-error* t) (setf *caught-error* t)
(asdf:run-shell-command (asdf:run-shell-command
"cp try-reloading-dependency.hidden try-reloading-dependency.asd") "cp try-reloading-dependency.hidden try-reloading-dependency.asd")
(format t "trlc1 5~%") ;;(format t "trlc1 5~%")
(multiple-value-bind (name mode) (multiple-value-bind (name mode)
(find-symbol (symbol-name 'retry) :asdf) (find-symbol (symbol-name 'retry) :asdf)
(assert (eq mode :external) nil "Mode of ~s was not external" name) (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))) (let ((restart (find-restart name c)))
(format t "trlc1 7~%") ;;(format t "trlc1 7~%")
(assert restart) (assert restart)
(format t "~&restart: ~S~&" restart) (format t "~&restart: ~S~&" restart)
(when restart (invoke-restart restart))))))) (when restart (invoke-restart restart)))))))
(format t "trlc1 3~%") ;;(format t "trlc1 3~%")
(asdf:oos 'asdf:load-op 'try-reloading-1)) (asdf:oos 'asdf:load-op 'try-reloading-1))
(format t "trlc1 4~%") ;;(format t "trlc1 4~%")
(assert *caught-error*)) (assert *caught-error*))
...@@ -23,6 +23,18 @@ ...@@ -23,6 +23,18 @@
(make-pathname :name nil :type "bar" :directory '(:absolute "tmp")) (make-pathname :name nil :type "bar" :directory '(:absolute "tmp"))
(make-pathname :name "." :type nil :directory '(:absolute "tmp")) (make-pathname :name "." :type nil :directory '(:absolute "tmp"))
(make-pathname :name "." :type "" :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 (assert
(asdf::version-satisfies (asdf:asdf-version) (asdf:asdf-version))) (asdf::version-satisfies (asdf:asdf-version) (asdf:asdf-version)))
(assert (assert
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment