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

1.669: fix and document the apply-output-translations function.

parent 054bf9dc
No related branches found
No related tags found
No related merge requests found
...@@ -60,7 +60,7 @@ ...@@ -60,7 +60,7 @@
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
(let* ((asdf-version (let* ((asdf-version
;; the 1+ hair is to ensure that we don't do an inadvertent find and replace ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
(subseq "VERSION:1.668" (1+ (length "VERSION")))) (subseq "VERSION:1.669" (1+ (length "VERSION"))))
#+allegro (excl::*autoload-package-name-alist* nil) #+allegro (excl::*autoload-package-name-alist* nil)
(existing-asdf (find-package :asdf)) (existing-asdf (find-package :asdf))
(versym '#:*asdf-version*) (versym '#:*asdf-version*)
...@@ -669,9 +669,13 @@ actually-existing directory." ...@@ -669,9 +669,13 @@ actually-existing directory."
"Resolve as much of a pathname as possible" "Resolve as much of a pathname as possible"
(block nil (block nil
(when (typep p 'logical-pathname) (return p)) (when (typep p 'logical-pathname) (return p))
(ignore-errors (return (truename p))) (let* ((p (merge-pathnames p))
(let ((directory (pathname-directory p))) (directory (pathname-directory p)))
(when (or (atom directory) (not (eq :absolute (car directory)))) (when (typep p 'logical-pathname) (return p))
(ignore-errors (return (truename p)))
(when (stringp directory)
(return p))
(when (not (eq :absolute (car directory)))
(return p)) (return p))
(let ((sofar (ignore-errors (truename (pathname-root p))))) (let ((sofar (ignore-errors (truename (pathname-root p)))))
(unless sofar (return p)) (unless sofar (return p))
...@@ -2596,51 +2600,53 @@ effectively disabling the output translation facility." ...@@ -2596,51 +2600,53 @@ effectively disabling the output translation facility."
(ensure-output-translations) (ensure-output-translations)
(loop :with p = (truenamize path) (loop :with p = (truenamize path)
:for (source destination) :in (car *output-translations*) :for (source destination) :in (car *output-translations*)
:when (or (eq source t) :for root = (when (or (eq source t)
(and (absolute-pathname-p source) (pathname-match-p p source)) (and (pathnamep source)
(and (pathnamep source) (not (absolute-pathname-p source))))
(pathname-match-p p (merge-pathnames* source (pathname-root p))))) (pathname-root p))
:for absolute-source = (cond
((eq source t) (wilden root))
(root (merge-pathnames* source root))
(t source))
:when (or (eq source t) (pathname-match-p p absolute-source))
:return :return
(cond (cond
((functionp destination) ((functionp destination)
(funcall destination p source)) (funcall destination p absolute-source))
((eq destination t) ((eq destination t)
p) p)
((and (eq source t) (pathnamep destination)) ((not (pathnamep destination))
(translate-full-pathname p destination)) (error "invalid destination"))
((not (absolute-pathname-p destination))
(translate-pathname p absolute-source (merge-pathnames* destination root)))
(root
(translate-pathname (directorize-pathname-host-device p) absolute-source destination))
(t (t
(translate-pathname p source destination))) (translate-pathname p absolute-source destination)))
:finally (return p))))) :finally (return p)))))
(defun last-char (s) (defun last-char (s)
(and (stringp s) (plusp (length s)) (char s (1- (length s))))) (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
(defun translate-full-pathname (source destination) (defun directorize-pathname-host-device (pathname)
(let* ((source-root (pathname-root source)) (let* ((root (pathname-root pathname))
(wild-source (wilden source-root)) (wild-root (wilden root))
(absolute-source (merge-pathnames* source source-root)) (absolute-pathname (merge-pathnames* pathname root))
(absolute-destination (merge-pathnames* destination source-root)) (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
(wild-destination (separator (last-char (namestring foo)))
(if (wild-pathname-p absolute-destination) (root-namestring (namestring root))
absolute-destination (root-string
(wilden absolute-destination)))
(destination-root (pathname-root absolute-destination))
(source-foo (make-pathname :directory '(:absolute "FOO") :defaults source-root))
(source-separator (last-char (namestring source-foo)))
(source-root-namestring (namestring source-root))
(source-root-string
(substitute-if #\/ (substitute-if #\/
(lambda (x) (or (eql x #\:) (lambda (x) (or (eql x #\:)
(eql x source-separator))) (eql x separator)))
source-root-namestring))) root-namestring)))
(multiple-value-bind (relative path filename) (multiple-value-bind (relative path filename)
(component-name-to-pathname-components source-root-string t) (component-name-to-pathname-components root-string t)
(declare (ignore relative filename)) (declare (ignore relative filename))
(let* ((new-base (let ((new-base
(make-pathname :defaults source-root (make-pathname :defaults root
:directory `(:absolute ,@path))) :directory `(:absolute ,@path))))
(rebased-source (translate-pathname absolute-source wild-source (wilden new-base)))) (translate-pathname absolute-pathname wild-root (wilden new-base))))))
(translate-pathname rebased-source wild-source wild-destination)))))
(defmethod output-files :around (operation component) (defmethod output-files :around (operation component)
"Translate output files, unless asked not to" "Translate output files, unless asked not to"
......
...@@ -2172,19 +2172,34 @@ You may use @code{#+features} to customize the configuration file. ...@@ -2172,19 +2172,34 @@ You may use @code{#+features} to customize the configuration file.
The second designator of a mapping may be @code{NIL}, indicating that files are not mapped The second designator of a mapping may be @code{NIL}, indicating that files are not mapped
to anything but themselves (same as if the second designator was the same as the first). to anything but themselves (same as if the second designator was the same as the first).
When the first designator is @code{t},
the mapping always matches.
When the first designator starts with @code{:root},
the mapping matches any host and device.
In either of these cases, if the second designator
isn't @code{t} and doesn't start with @code{:root},
then strings indicating the host and pathname are somehow copied
in the beginning of the directory component of the source pathname
before it is translated.
When the second designator is @code{t}, the mapping is the identity.
When the second designator starts with @code{root},
the mapping preserves the host and device of the original pathname.
@code{:include} statements cause the search to recurse with the path specifications @code{:include} statements cause the search to recurse with the path specifications
from the file specified. from the file specified.
If the @code{translate-pathname} mechanism cannot achieve a desired If the @code{translate-pathname} mechanism cannot achieve a desired
translation, the user may provide a function which provides the translation, the user may provide a function which provides the
required algorithim. Such a translation function is specified by required algorithim. Such a translation function is specified by
supplying a list as the second @code{directory-designator} whose first supplying a list as the second @code{directory-designator}
element is the keyword @code{:function}, and whose second element is the first element of which is the keyword @code{:function},
and the second element of which is
either a symbol which designates a function or a lambda expression. either a symbol which designates a function or a lambda expression.
The function designated by the second argument must take two The function designated by the second argument must take two arguments,
arguments, the first being the pathname of the source file, the second the first being the pathname of the source file,
being the wildcard that was matched. The result of the function the second being the wildcard that was matched.
invocation should be the translated pathname. The result of the function invocation should be the translated pathname.
An @code{:inherit-configuration} statement cause the search to recurse with the path An @code{:inherit-configuration} statement cause the search to recurse with the path
specifications from the next configuration. specifications from the next configuration.
......
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