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
......@@ -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)
(funcall collect
(list trusrc
(if (symbolp (second dst))
(fdefinition (second dst))
(eval (second dst)))))
(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))))))))))
(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))))))
((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 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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment