From 054bf9dcce3912f8be42293c4112f767d2abe866 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Thu, 8 Apr 2010 00:36:46 -0400 Subject: [PATCH] 1.668: in output translations, have :root mean "relative to the source pathname's host and device" --- asdf.lisp | 81 ++++++++++++++++++++++++------------------------ doc/asdf.texinfo | 1 + 2 files changed, 42 insertions(+), 40 deletions(-) diff --git a/asdf.lisp b/asdf.lisp index fec92666..0cf1b1f2 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -60,7 +60,7 @@ (eval-when (:load-toplevel :compile-toplevel :execute) (let* ((asdf-version ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace - (subseq "VERSION:1.667" (1+ (length "VERSION")))) + (subseq "VERSION:1.668" (1+ (length "VERSION")))) #+allegro (excl::*autoload-package-name-alist* nil) (existing-asdf (find-package :asdf)) (versym '#:*asdf-version*) @@ -659,19 +659,21 @@ actually-existing directory." (handler-case (parse-integer (read-line stream)) (error () (error "Unable to find out user ID"))))))) +(defun pathname-root (pathname) + (make-pathname :host (pathname-host pathname) + :device (pathname-device pathname) + :directory '(:absolute) + :name nil :type nil :version nil)) + (defun truenamize (p) "Resolve as much of a pathname as possible" (block nil (when (typep p 'logical-pathname) (return p)) (ignore-errors (return (truename p))) - (let ((host (pathname-host p)) - (device (pathname-device p)) - (directory (pathname-directory p))) + (let ((directory (pathname-directory p))) (when (or (atom directory) (not (eq :absolute (car directory)))) (return p)) - (let ((sofar (ignore-errors - (truename (make-pathname :host host :device device - :directory '(:absolute)))))) + (let ((sofar (ignore-errors (truename (pathname-root p))))) (unless sofar (return p)) (loop :for component :in (cdr directory) :for rest :on (cdr directory) @@ -2327,6 +2329,11 @@ with a different configuration, so the configuration would be re-read then." (let ((cdr (resolve-relative-location-component car (cdr x) wildenp))) (merge-pathnames* cdr car))))) + ((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)))) ((eql :home) (user-homedir)) ((eql :user-cache) (resolve-location *user-cache* nil)) ((eql :system-cache) (resolve-location *system-cache* nil)) @@ -2589,7 +2596,10 @@ effectively disabling the output translation facility." (ensure-output-translations) (loop :with p = (truenamize path) :for (source destination) :in (car *output-translations*) - :when (or (eq source t) (pathname-match-p p source)) + :when (or (eq source t) + (and (absolute-pathname-p source) (pathname-match-p p source)) + (and (pathnamep source) + (pathname-match-p p (merge-pathnames* source (pathname-root p))))) :return (cond ((functionp destination) @@ -2606,40 +2616,31 @@ effectively disabling the output translation facility." (and (stringp s) (plusp (length s)) (char s (1- (length s))))) (defun translate-full-pathname (source destination) - (let* ((absolute-destination (merge-pathnames* destination source)) + (let* ((source-root (pathname-root source)) + (wild-source (wilden source-root)) + (absolute-source (merge-pathnames* source source-root)) + (absolute-destination (merge-pathnames* destination source-root)) (wild-destination (if (wild-pathname-p absolute-destination) - absolute-destination - (wilden absolute-destination)))) - #+(or unix cygwin) - (translate-pathname source (wilden "/") wild-destination) - #-(or unix cygwin) - (let* ((base-pathname - (make-pathname :directory '(:absolute "FOO") - :defaults destination)) - (separator - (last-char (namestring base-pathname))) - (host-device-namestring (namestring - (make-pathname - :directory nil :name nil :type nil :version nil - :defaults source))) - (new-base (concatenate 'string (namestring base-pathname) - (substitute separator #\: host-device-namestring) - separator)) - (src-dir (pathname-directory source)) - (source-relativized-directory - (cond - ((null src-dir) '(:relative)) - ((stringp src-dir) '(:relative ,src-dir)) - ((and (consp src-dir) (member (car src-dir) '(:absolute :relative))) - `(:relative ,@(cdr src-dir))))) - (rebased-source (merge-pathnames* - (make-pathname :host nil :device nil - :directory source-relativized-directory - :defaults source) - base-pathname))) - (translate-pathname rebased-source (wilden base-pathname) wild-destination)))) - + absolute-destination + (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 #\/ + (lambda (x) (or (eql x #\:) + (eql x source-separator))) + source-root-namestring))) + (multiple-value-bind (relative path filename) + (component-name-to-pathname-components source-root-string t) + (declare (ignore relative filename)) + (let* ((new-base + (make-pathname :defaults source-root + :directory `(:absolute ,@path))) + (rebased-source (translate-pathname absolute-source wild-source (wilden new-base)))) + (translate-pathname rebased-source wild-source wild-destination))))) (defmethod output-files :around (operation component) "Translate output files, unless asked not to" diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo index e433aa75..fb3c7995 100644 --- a/doc/asdf.texinfo +++ b/doc/asdf.texinfo @@ -2134,6 +2134,7 @@ DIRECTORY-DESIGNATOR := ABSOLUTE-COMPONENT-DESIGNATOR := NULL | ;; As source: skip this entry. As destination: same as source + :ROOT | ;; magic: paths that are relative to the root of the source host and device STRING | ;; namestring (directory is assumed, better be absolute or bust, ``/**/*.*'' added) PATHNAME | ;; pathname (better be an absolute directory or bust) :HOME | ;; designates the user-homedir-pathname ~/ -- GitLab