Commit 1e1cd5b7 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

1.667: wholly untested infrastructure to support centralized cache on Windows.

* remove :root (not portable) as pathname designator component. Accept t as pathname designator.
* also, #+abcl translate-jar-pathname. Oops.
parent 5c336952
Loading
Loading
Loading
Loading
+85 −28
Original line number Diff line number Diff line
@@ -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.666" (1+ (length "VERSION"))))
          (subseq "VERSION:1.667" (1+ (length "VERSION"))))
         #+allegro (excl::*autoload-package-name-alist* nil)
         (existing-asdf (find-package :asdf))
         (versym '#:*asdf-version*)
@@ -2160,9 +2160,12 @@ located."
;;; ---------------------------------------------------------------------------
;;; Generic support for configuration files

(defparameter *inter-directory-separator*
  #+(or unix cygwin) #\:
  #-(or unix cygwin) #\;)

(defun user-homedir ()
  #+cmu (truename (user-homedir-pathname))
  #-cmu (user-homedir-pathname))
  (truename (user-homedir-pathname)))

(defun try-directory-subpath (x sub &key type)
  (let* ((p (and x (ensure-directory-pathname x)))
@@ -2275,7 +2278,8 @@ and the order is by decreasing length of namestring of the source pathname.")
   #+windows
   (let ((h (or (getenv "USERPROFILE") (user-homedir))))
     (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp")))
   '(:root "var" "cache" "common-lisp" :uid :implementation)))
   #+(or unix cygwin)
   '("/var/cache/common-lisp" :uid :implementation)))

(defun output-translations ()
  (car *output-translations*))
@@ -2284,7 +2288,11 @@ and the order is by decreasing length of namestring of the source pathname.")
  (setf *output-translations*
        (list
         (stable-sort (copy-list x) #'>
                      :key (lambda (x) (length (pathname-directory (car x))))))))
                      :key (lambda (x)
                             (etypecase (car x)
                               ((eql t) -1)
                               (pathname
                                (length (pathname-directory (car x))))))))))

(defun output-translations-initialized-p ()
  (and *output-translations* t))
@@ -2322,8 +2330,7 @@ with a different configuration, so the configuration would be re-read then."
            ((eql :home) (user-homedir))
            ((eql :user-cache) (resolve-location *user-cache* nil))
            ((eql :system-cache) (resolve-location *system-cache* nil))
            ((eql :current-directory) (truenamize *default-pathname-defaults*))
            ((eql :root) (make-pathname :directory '(:absolute)))))
            ((eql :current-directory) (truenamize *default-pathname-defaults*))))
         (s (if (and wildenp (not (pathnamep x)))
                (wilden r)
                r)))
@@ -2367,7 +2374,7 @@ with a different configuration, so the configuration would be re-read then."

(defun location-designator-p (x)
  (flet ((componentp (c) (typep c '(or string pathname keyword))))
    (or (null x) (componentp x) (and (consp x) (every #'componentp x)))))
    (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))

(defun location-function-p (x)
  (and
@@ -2428,7 +2435,7 @@ with a different configuration, so the configuration would be re-read then."
      :with start = 0
      :with end = (length string)
      :with source = nil
      :for i = (or (position #\: string :start start) end) :do
      :for i = (or (position *inter-directory-separator* string :start start) end) :do
      (let ((s (subseq string start i)))
        (cond
          (source
@@ -2517,9 +2524,9 @@ with a different configuration, so the configuration would be re-read then."
  (if (atom directive)
      (ecase directive
        ((:enable-user-cache)
         (process-output-translations-directive '(:root :user-cache) :collect collect))
         (process-output-translations-directive '(t :user-cache) :collect collect))
        ((:disable-cache)
         (process-output-translations-directive '(:root :root) :collect collect))
         (process-output-translations-directive '(t t) :collect collect))
        ((:inherit-configuration)
         (inherit-output-translations inherit :collect collect))
        ((:ignore-inherited-configuration)
@@ -2530,17 +2537,21 @@ with a different configuration, so the configuration would be re-read then."
            (when dst
              (process-output-translations (pathname dst) :inherit nil :collect collect))
            (when src
              (let ((trusrc (truenamize (resolve-location src t))))
                (if (location-function-p dst)
              (let ((trusrc (or (eql src t) (truenamize (resolve-location src t)))))
                (cond
                  ((location-function-p dst)
                   (funcall collect
                            (list trusrc
                                  (if (symbolp (second dst))
                                      (fdefinition (second dst))
                                       (eval (second dst)))))
                                      (eval (second dst))))))
                  ((eq dst t)
                   (funcall collect (list trusrc t)))
                  (t
                   (let* ((trudst (if dst (resolve-location dst t) trusrc))
                          (wilddst (make-pathname :name :wild :type :wild :defaults trudst)))
                      (funcall collect (list wilddst wilddst))
                      (funcall collect (list trusrc trudst))))))))))
                     (funcall collect (list wilddst t))
                     (funcall collect (list trusrc trudst)))))))))))

(defun compute-output-translations (&optional parameter)
  "read the configuration, return it"
@@ -2578,13 +2589,58 @@ effectively disabling the output translation facility."
     (ensure-output-translations)
     (loop :with p = (truenamize path)
       :for (source destination) :in (car *output-translations*)
       :when (pathname-match-p p source)
       :when (or (eq source t) (pathname-match-p p source))
       :return
        (if (functionp destination)
            (funcall destination p source)
            (translate-pathname p source destination))
       (cond
         ((functionp destination)
          (funcall destination p source))
         ((eq destination t)
          p)
         ((and (eq source t) (pathnamep destination))
          (translate-full-pathname p destination))
         (t
          (translate-pathname p source destination)))
       :finally (return p)))))

(defun last-char (s)
  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))

(defun translate-full-pathname (source destination)
  (let* ((absolute-destination (merge-pathnames* destination source))
         (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))))


(defmethod output-files :around (operation component)
  "Translate output files, unless asked not to"
  (declare (ignorable operation component))
@@ -2601,6 +2657,7 @@ effectively disabling the output translation facility."
          (truenamize (lispize-pathname input-file))
          keys)))

#+abcl
(defun translate-jar-pathname (source wildcard)
  (declare (ignore wildcard))
  (let ((root (apply-output-translations
@@ -2643,7 +2700,7 @@ effectively disabling the output translation facility."
       ,@source-to-target-mappings
       ((:root ,wild-inferiors ,mapped-files)
        (,@destination-directory ,mapped-files))
       (:root :root)
       (t t)
       :ignore-inherited-configuration))))

;;;; -----------------------------------------------------------------
@@ -2814,7 +2871,7 @@ with a different configuration, so the configuration would be re-read then."
      :with directives = ()
      :with start = 0
      :with end = (length string)
      :for pos = (position #\: string :start start) :do
      :for pos = (position *inter-directory-separator* string :start start) :do
      (let ((s (subseq string start (or pos end))))
        (cond
         ((equal "" s) ; empty element: inherit
+18 −9
Original line number Diff line number Diff line
@@ -500,7 +500,7 @@ To wholly disable output translations for all directories,
you can create a file @file{00-disable.conf}
with the line:

@kbd{(:root :root)}
@kbd{(t t)}

Note that your Operating System distribution or your system administrator
may already have configured translations for you.
@@ -1772,7 +1772,11 @@ ASDF will skip to next configuration if it's an empty string.
It will @code{READ} the string as a SEXP in the DSL
if it begins with a paren @code{(}
and it will be interpreted much like @code{TEXINPUTS}
as @code{:} (colon) separated list of paths, where
list of paths, where

  * paths are separated
   by a @code{:} (colon) on Unix platforms (including cygwin),
   by a @code{;} (semicolon) on other platforms (mainly, Windows).

  * each entry is a directory to add to the search path.

@@ -2124,6 +2128,7 @@ DIRECTIVE :=
    (DIRECTORY-DESIGNATOR (:function TRANSLATION-FUNCTION))

DIRECTORY-DESIGNATOR :=
    T | ;; as source matches anything, as destination leaves pathname unmapped.
    ABSOLUTE-COMPONENT-DESIGNATOR |
    (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...)

@@ -2134,7 +2139,6 @@ ABSOLUTE-COMPONENT-DESIGNATOR :=
    :HOME | ;; designates the user-homedir-pathname ~/
    :USER-CACHE | ;; designates the default location for the user cache
    :SYSTEM-CACHE | ;; designates the default location for the system cache
    :ROOT | ;; the root of the filesystem hierarchy
    :CURRENT-DIRECTORY ;; the current directory

RELATIVE-COMPONENT-DESIGNATOR :=
@@ -2187,9 +2191,9 @@ specifications from the next configuration.

@itemize
@item
@code{:enable-user-cache} is the same as @code{(:root :user-cache)}.
@code{:enable-user-cache} is the same as @code{(t :user-cache)}.
@item
@code{:disable-cache} is the same as @code{(:root :root)}.
@code{:disable-cache} is the same as @code{(t t)}.
@item
@code{:user-cache} uses the contents of variable @code{asdf::*user-cache*}
which by default is the same as using
@@ -2197,7 +2201,8 @@ which by default is the same as using
@item
@code{:system-cache} uses the contents of variable @code{asdf::*system-cache*}
which by default is the same as using
@code{(:root "var" "cache" "common-lisp" :uid :implementation-type)}
@code{("/var/cache/common-lisp" :uid :implementation-type)}
(on Unix and cygwin), or something semi-sensible on Windows.
@end itemize


@@ -2233,8 +2238,11 @@ When considering environment variable @code{ASDF_OUTPUT_TRANSLATIONS}
ASDF will skip to next configuration if it's an empty string.
It will @code{READ} the string as an SEXP in the DSL
if it begins with a paren @code{(}
and it will be interpreted as a colon-separated list of directories.
and it will be interpreted as a list of directories.
Directories should come by pairs, indicating a mapping directive.
Entries are separated
by a @code{:} (colon) on Unix platforms (including cygwin),
by a @code{;} (semicolon) on other platforms (mainly, Windows).

The magic empty entry,
if it comes in what would otherwise be the first entry in a pair,
@@ -2721,7 +2729,8 @@ with a shell variable (see below) or some other runtime command
(e.g. some call to @code{asdf:initialize-output-translations}).

To disable the compiler output cache in Lisp processes
run by your current shell, try (assuming @code{bash} or @code{zsh}):
run by your current shell, try (assuming @code{bash} or @code{zsh})
(on Unix and cygwin only):

@example
export ASDF_OUTPUT_TRANSLATIONS=/:
@@ -2731,7 +2740,7 @@ To disable the compiler output cache just in the current Lisp process,
use (after loading ASDF but before using it):

@example
(asdf:initialize-output-translations "/:")
(asdf:disable-output-translations)
@end example

@section Issues with using and extending ASDF to define systems