Newer
Older
Francois-Rene Rideau
committed
;;;; -------------------------------------------------------------------------
;;;; load-source-op
(defclass load-source-op (basic-load-op) ())
(defmethod perform ((o load-source-op) (c cl-source-file))

Kevin Rosenberg
committed
(let ((source (component-pathname c)))
(setf (component-property c 'last-loaded-as-source)
(and (load source)
(get-universal-time)))))
(defmethod perform ((operation load-source-op) (c static-file))
(declare (ignorable operation c))

Kevin Rosenberg
committed
nil)
(defmethod output-files ((operation load-source-op) (c component))
(declare (ignorable operation c))

Kevin Rosenberg
committed
nil)
;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.
(defmethod component-depends-on ((o load-source-op) (c component))

Kevin Rosenberg
committed
(let ((what-would-load-op-do (cdr (assoc 'load-op
Francois-Rene Rideau
committed
(component-in-order-to c)))))

Kevin Rosenberg
committed
(mapcar (lambda (dep)
(if (eq (car dep) 'load-op)
(cons 'load-source-op (cdr dep))
dep))
what-would-load-op-do)))
(defmethod operation-done-p ((o load-source-op) (c source-file))

Kevin Rosenberg
committed
(if (or (not (component-property c 'last-loaded-as-source))
(> (safe-file-write-date (component-pathname c))
(component-property c 'last-loaded-as-source)))

Kevin Rosenberg
committed
nil t))
Francois-Rene Rideau
committed
(defmethod operation-description ((operation load-source-op) component)
(declare (ignorable operation))
Francois-Rene Rideau
committed
(format nil "loading component ~S" (component-find-path component)))
;;;; -------------------------------------------------------------------------
;;;; test-op
(defclass test-op (operation) ())
(defmethod perform ((operation test-op) (c component))
(declare (ignorable operation c))
(defmethod operation-done-p ((operation test-op) (c system))
"Testing a system is _never_ done."
(declare (ignorable operation c))
(defmethod component-depends-on :around ((o test-op) (c system))
(cons `(load-op ,(component-name c)) (call-next-method)))
;;;; -------------------------------------------------------------------------
;;;; Invoking Operations
Francois-Rene Rideau
committed
(defgeneric* operate (operation-class system &key &allow-other-keys))
Francois-Rene Rideau
committed
(defmethod operate (operation-class system &rest args
&key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
&allow-other-keys)
(let* ((*package* *package*)
(*readtable* *readtable*)
(op (apply #'make-instance operation-class
(*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
(system (if (typep system 'component) system (find-system system))))
(unless (version-satisfies system version)
Gary King
committed
(error 'missing-component-of-version :requires system :version version))
(let ((steps (traverse op system)))
(with-compilation-unit ()
(loop :for (op . component) :in steps :do
(loop
(restart-case
Francois-Rene Rideau
committed
(progn
(perform-with-restarts op component)
(return))
(retry ()
:report
(lambda (s)
Francois-Rene Rideau
committed
(format s "~@<Retry ~A.~@:>" (operation-description op component))))
(accept ()
:report
(lambda (s)
(format s "~@<Continue, treating ~A as having been successful.~@:>"
Francois-Rene Rideau
committed
(operation-description op component)))
(setf (gethash (type-of op)
(component-operation-times component))
(get-universal-time))
(return))))))
(values op steps))))
(defun* oos (operation-class system &rest args &key force verbose version
Gary King
committed
(declare (ignore force verbose version))
(apply #'operate operation-class system args))
(let ((operate-docstring
"Operate does three things:
Francois-Rene Rideau
committed
1. It creates an instance of OPERATION-CLASS using any keyword parameters
Francois-Rene Rideau
committed
2. It finds the asdf-system specified by SYSTEM (possibly loading
Francois-Rene Rideau
committed
3. It then calls TRAVERSE with the operation and system as arguments
Francois-Rene Rideau
committed
The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
handling code. If a VERSION argument is supplied, then operate also
ensures that the system found satisfies it using the VERSION-SATISFIES
method.
Note that dependencies may cause the operation to invoke other
operations on the system or its components: the new operations will be
created with the same initargs as the original one.
"))
(setf (documentation 'oos 'function)
"Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"
(setf (documentation 'operate 'function)
(defun* load-system (system &rest args &key force verbose version
Francois-Rene Rideau
committed
&allow-other-keys)
"Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
Francois-Rene Rideau
committed
details."
(declare (ignore force verbose version))
(apply #'operate 'load-op system args)
t)
(defun* compile-system (system &rest args &key force verbose version
Francois-Rene Rideau
committed
&allow-other-keys)
"Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
Francois-Rene Rideau
committed
for details."
(declare (ignore force verbose version))
(apply #'operate 'compile-op system args)
t)
(defun* test-system (system &rest args &key force verbose version
Francois-Rene Rideau
committed
&allow-other-keys)
"Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
Francois-Rene Rideau
committed
details."
(declare (ignore force verbose version))
(apply #'operate 'test-op system args)
t)
;;;; -------------------------------------------------------------------------
;;;; Defsystem
(defun* load-pathname ()
(let ((pn (or *load-pathname* *compile-file-pathname*)))
(if *resolve-symlinks*
(and pn (resolve-symlinks pn))
pn)))
(defun* determine-system-pathname (pathname pathname-supplied-p)
;; The defsystem macro calls us to determine
;; the pathname of a system as follows:
;; 1. the one supplied,
;; 2. derived from *load-pathname* via load-pathname
Francois-Rene Rideau
committed
;; 3. taken from the *default-pathname-defaults* via default-directory
(let* ((file-pathname (load-pathname))
(directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
(or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
directory-pathname
Francois-Rene Rideau
committed
(default-directory))))
(destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
options
Francois-Rene Rideau
committed
(let ((component-options (remove-keys '(:class) options)))
;; system must be registered before we parse the body, otherwise
;; we recur when trying to find an existing system of the same name
;; to reuse options (e.g. pathname) from
Francois-Rene Rideau
committed
:collect `(load-system ,system))
(let ((s (system-registered-p ',name)))
(cond ((and s (eq (type-of (cdr s)) ',class))
(setf (car s) (get-universal-time)))
(s
(change-class (cdr s) ',class))
(t
(register-system (quote ,name)
(make-instance ',class :name ',name))))
(%set-system-source-file (load-pathname)
:module (coerce-name ',name)
:pathname
,(determine-system-pathname pathname pathname-arg-p)
',component-options))))))
(defun* class-for-type (parent type)
Francois-Rene Rideau
committed
type
(find-symbol (symbol-name type) *package*)
(find-symbol (symbol-name type) :asdf))
:for class = (and symbol (find-class symbol nil))
:when (and class (subtypep class 'component))
:return class)
(and (eq type :file)
(or (module-default-component-class parent)
(find-class *default-component-class*)))
(sysdef-error "~@<don't recognize component type ~A~@:>" type)))
(defun* maybe-add-tree (tree op1 op2 c)
"Add the node C at /OP1/OP2 in TREE, unless it's there already.
Returns the new tree (which probably shares structure with the old one)"
(let ((first-op-tree (assoc op1 tree)))
(if first-op-tree
(progn
(aif (assoc op2 (cdr first-op-tree))
(if (find c (cdr it))
nil
(setf (cdr it) (cons c (cdr it))))
(setf (cdr first-op-tree)
(acons op2 (list c) (cdr first-op-tree))))
tree)
(acons op1 (list (list op2 c)) tree))))
(defun* union-of-dependencies (&rest deps)
(let ((new-tree nil))
(dolist (dep deps)
(dolist (op-tree dep)
(dolist (op (cdr op-tree))
(dolist (c (cdr op))
(setf new-tree
(maybe-add-tree new-tree (car op-tree) (car op) c))))))
(defvar *serial-depends-on* nil)
(defun* sysdef-error-component (msg type name value)
(sysdef-error (concatenate 'string msg
"~&The value specified for ~(~A~) ~A is ~S")
type name value))
(defun* check-component-input (type name weakly-depends-on
"A partial test of the values of a component."
(unless (listp depends-on)
(sysdef-error-component ":depends-on must be a list."
type name depends-on))
(unless (listp weakly-depends-on)
(sysdef-error-component ":weakly-depends-on must be a list."
type name weakly-depends-on))
(unless (listp components)
(sysdef-error-component ":components must be NIL or a list of components."
type name components))
(unless (and (listp in-order-to) (listp (car in-order-to)))
(sysdef-error-component ":in-order-to must be NIL or a list of components."
type name in-order-to)))
(defun* %remove-component-inline-methods (component)
(dolist (name +asdf-methods+)
(map ()
;; this is inefficient as most of the stored
;; methods will not be for this particular gf
;; But this is hardly performance-critical
(lambda (m)
(remove-method (symbol-function name) m))
(component-inline-methods component)))
;; clear methods, then add the new ones
(setf (component-inline-methods component) nil))
(defun* %define-component-inline-methods (ret rest)
(dolist (name +asdf-methods+)
(let ((keyword (intern (symbol-name name) :keyword)))
(loop :for data = rest :then (cddr data)
:for key = (first data)
:for value = (second data)
:while data
:when (eq key keyword) :do
(destructuring-bind (op qual (o c) &body body) value
(pushnew
(eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
,@body))
(component-inline-methods ret)))))))
(defun* %refresh-component-inline-methods (component rest)
(%remove-component-inline-methods component)
(%define-component-inline-methods component rest))
(defun* parse-component-form (parent options)
(type name &rest rest &key
;; the following list of keywords is reproduced below in the
;; remove-keys form. important to keep them in sync
components pathname default-component-class
perform explain output-files operation-done-p
weakly-depends-on
depends-on serial in-order-to
;; list ends
&allow-other-keys) options
(declare (ignorable perform explain output-files operation-done-p))
(check-component-input type name weakly-depends-on depends-on components in-order-to)
(when (and parent
(find-component parent name)
;; ignore the same object when rereading the defsystem
(not
(typep (find-component parent name)
(class-for-type parent type))))
(error 'duplicate-names :name name))
(let* ((other-args (remove-keys
'(components pathname default-component-class
perform explain output-files operation-done-p
weakly-depends-on
depends-on serial in-order-to)
rest))
(ret
(or (find-component parent name)
(make-instance (class-for-type parent type)))))
(appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
(when *serial-depends-on*
(push *serial-depends-on* depends-on))
(apply #'reinitialize-instance ret
:name (coerce-name name)
:pathname pathname
:parent parent
other-args)
(component-pathname ret) ; eagerly compute the absolute pathname
(when (typep ret 'module)
(setf (module-default-component-class ret)
(or default-component-class
(and (typep parent 'module)
(module-default-component-class parent))))
(let ((*serial-depends-on* nil))
(setf (module-components ret)
(loop
:for c-form :in components
:for c = (parse-component-form ret c-form)
:when serial :do (setf *serial-depends-on* name))))
(compute-module-components-by-name ret))
(setf (component-load-dependencies ret) depends-on) ;; Used by POIU
Francois-Rene Rideau
committed
(setf (component-in-order-to ret)
(union-of-dependencies
in-order-to
`((compile-op (compile-op ,@depends-on))
(load-op (load-op ,@depends-on)))))
(setf (component-do-first ret) `((compile-op (load-op ,@depends-on))))
ret)))
Francois-Rene Rideau
committed
;;;; ---------------------------------------------------------------------------
;;;; run-shell-command
;;;;
;;;; run-shell-command functions for other lisp implementations will be
;;;; gratefully accepted, if they do the same thing.
;;;; If the docstring is ambiguous, send a bug report.
Francois-Rene Rideau
committed
;;;;
;;;; We probably should move this functionality to its own system and deprecate
;;;; use of it from the asdf package. However, this would break unspecified
;;;; existing software, so until a clear alternative exists, we can't deprecate
;;;; it, and even after it's been deprecated, we will support it for a few
;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
(defun* run-shell-command (control-string &rest args)
Francois-Rene Rideau
committed
"Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell, with
Francois-Rene Rideau
committed
output to *VERBOSE-OUT*. Returns the shell's exit code."
(let ((command (apply #'format nil control-string args)))
(asdf-message "; $ ~A~%" command)
#+abcl
(ext:run-shell-command command :output *verbose-out*)
#+allegro
;; will this fail if command has embedded quotes - it seems to work
(multiple-value-bind (stdout stderr exit-code)
(excl.osi:command-output
(format nil "~a -c \"~a\""
#+mswindows "sh" #-mswindows "/bin/sh" command)
:input nil :whole nil
#+mswindows :show-window #+mswindows :hide)
(asdf-message "~{~&; ~a~%~}~%" stderr)
(asdf-message "~{~&; ~a~%~}~%" stdout)
#+clisp ;XXX not exactly *verbose-out*, I know
(ext:run-shell-command command :output :terminal :wait t)
(nth-value 1
(ccl:external-process-status
(ccl:run-program "/bin/sh" (list "-c" command)
:input nil :output *verbose-out*
:wait t)))
#+ecl ;; courtesy of Juan Jose Garcia Ripoll
(si:system command)
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
#+lispworks
(system:call-system-showing-output
command
:shell-type "/bin/sh"
:show-cmd nil
:prefix ""
:output-stream *verbose-out*)
#+sbcl
(sb-ext:process-exit-code
(apply #'sb-ext:run-program
#+win32 "sh" #-win32 "/bin/sh"
(list "-c" command)
:input nil :output *verbose-out*
#+win32 '(:search t) #-win32 nil))
#+(or cmu scl)
(ext:process-exit-code
(ext:run-program
"/bin/sh"
(list "-c" command)
:input nil :output *verbose-out*))
#-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
(error "RUN-SHELL-COMMAND not implemented for this Lisp")))
Francois-Rene Rideau
committed
;;;; ---------------------------------------------------------------------------
;;;; system-relative-pathname
(defmethod system-source-file ((system-name string))
(system-source-file (find-system system-name)))
(defmethod system-source-file ((system-name symbol))
(system-source-file (find-system system-name)))
(defun* system-source-directory (system-designator)
"Return a pathname object corresponding to the
directory in which the system specification (.asd file) is
located."
(make-pathname :name nil
:type nil
:defaults (system-source-file system-designator)))
(defun* relativize-directory (directory)
(cond
((stringp directory)
(list :relative directory))
((eq (car directory) :absolute)
(cons :relative (cdr directory)))
(t
directory)))
Francois-Rene Rideau
committed
(defun* relativize-pathname-directory (pathspec)
Francois-Rene Rideau
committed
(let ((p (pathname pathspec)))
(make-pathname
:directory (relativize-directory (pathname-directory p))
:defaults p)))
(defun* system-relative-pathname (system name &key type)
(merge-pathnames*
(merge-component-name-type name :type type)
(system-source-directory system)))
Francois-Rene Rideau
committed
;;; ---------------------------------------------------------------------------
Francois-Rene Rideau
committed
;;; implementation-identifier
Francois-Rene Rideau
committed
;;; produce a string to identify current implementation.
;;; Initially stolen from SLIME's SWANK, hacked since.
(defparameter *implementation-features*
'((:acl :allegro)
(:lw :lispworks)
(:digitool) ; before clozure, so it won't get preempted by ccl
(:ccl :clozure)
(:corman :cormanlisp)
(:abcl :armedbear)
:sbcl :cmu :clisp :gcl :ecl :scl))
'((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
Francois-Rene Rideau
committed
(:solaris :sunos)
(:linux :linux-target) ;; for GCL at least, must appear before :bsd.
(:macosx :darwin :darwin-target :apple)
(defparameter *architecture-features*
'((:amd64 :x86-64 :x86_64 :x8664-target)
(:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
:hppa64
:hppa
(:ppc64 :ppc64-target)
(:ppc32 :ppc32-target :ppc :powerpc)
:sparc64
(:sparc32 :sparc)
(:arm :arm-target)
(:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
Francois-Rene Rideau
committed
(defun* lisp-version-string ()
Francois-Rene Rideau
committed
(let ((s (lisp-implementation-version)))
(declare (ignorable s))
#+allegro (format nil
"~A~A~A~A"
excl::*common-lisp-version-number*
Francois-Rene Rideau
committed
;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
(if (eq excl:*current-case-mode*
:case-sensitive-lower) "M" "A")
;; Note if not using International ACL
;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
(excl:ics-target-case
Francois-Rene Rideau
committed
(:-ics "8")
(:+ics ""))
(if (member :64bit *features*) "-64bit" ""))
Francois-Rene Rideau
committed
#+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
#+clisp (subseq s 0 (position #\space s))
#+clozure (format nil "~d.~d-f~d" ; shorten for windows
ccl::*openmcl-major-version*
ccl::*openmcl-minor-version*
(logand ccl::fasl-version #xFF))
#+cmu (substitute #\- #\/ s)
#+digitool (subseq s 8)
#+ecl (format nil "~A~@[-~A~]" s
Francois-Rene Rideau
committed
(let ((vcs-id (ext:lisp-implementation-vcs-id)))
#+gcl (subseq s (1+ (position #\space s)))
#+lispworks (format nil "~A~@[~A~]" s
(when (member :lispworks-64bit *features*) "-64bit"))
Francois-Rene Rideau
committed
;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
#+(or cormanlisp mcl sbcl scl) s
#-(or allegro armedbear clisp clozure cmu cormanlisp digitool
ecl gcl lispworks mcl sbcl scl) s))
Francois-Rene Rideau
committed
(defun* first-feature (features)
Francois-Rene Rideau
committed
(labels
((fp (thing)
(etypecase thing
(symbol
(let ((feature (find thing *features*)))
(when feature (return-from fp feature))))
;; allows features to be lists of which the first
;; member is the "main name", the rest being aliases
(cons
(dolist (subf thing)
(when (find subf *features*) (return-from fp (first thing))))))
nil))
(loop :for f :in features
:when (fp f) :return :it)))
(defun* implementation-type ()
Francois-Rene Rideau
committed
(first-feature *implementation-features*))
(defun* implementation-identifier ()
Francois-Rene Rideau
committed
(labels
((maybe-warn (value fstring &rest args)
(cond (value)
(t (apply #'warn fstring args)
"unknown"))))
(let ((lisp (maybe-warn (implementation-type)
"No implementation feature found in ~a."
*implementation-features*))
(os (maybe-warn (first-feature *os-features*)
"No os feature found in ~a." *os-features*))
(arch (maybe-warn (first-feature *architecture-features*)
"No architecture feature found in ~a."
*architecture-features*))
(version (maybe-warn (lisp-version-string)
"Don't know how to get Lisp implementation version.")))
Francois-Rene Rideau
committed
(substitute-if
#\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
(format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
;;; ---------------------------------------------------------------------------
;;; Generic support for configuration files
Francois-Rene Rideau
committed
(defparameter *inter-directory-separator*
#+(or unix cygwin) #\:
#-(or unix cygwin) #\;)
(defun* user-homedir ()
Francois-Rene Rideau
committed
(truename (user-homedir-pathname)))
(defun* try-directory-subpath (x sub &key type)
Francois-Rene Rideau
committed
(tp (and p (probe-file* p)))
(sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
Francois-Rene Rideau
committed
(ts (and sp (probe-file* sp))))
(defun* user-configuration-directories ()
(remove-if
#'null
(flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
`(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
:for dir :in (split-string dirs :separator ":")
:collect (try dir "common-lisp/"))
#+(and (or win32 windows mswindows mingw32) (not cygwin))
,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
,(try (getenv "APPDATA") "common-lisp/config/"))
,(try (user-homedir) ".config/common-lisp/")))))
(defun* system-configuration-directories ()
#+(and (or win32 windows mswindows mingw32) (not cygwin))
(flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
`(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
(list #p"/etc/common-lisp/"))))
(defun* in-first-directory (dirs x)
Francois-Rene Rideau
committed
:thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))
(defun* in-user-configuration-directory (x)
(defun* in-system-configuration-directory (x)
(in-first-directory (system-configuration-directories) x))
Francois-Rene Rideau
committed
(defun* configuration-inheritance-directive-p (x)
Francois-Rene Rideau
committed
(let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
(or (member x kw)
(and (length=n-p x 1) (member (car x) kw)))))
(defun* validate-configuration-form (form tag directive-validator
Francois-Rene Rideau
committed
&optional (description tag))
(unless (and (consp form) (eq (car form) tag))
(error "Error: Form doesn't specify ~A ~S~%" description form))
(loop :with inherit = 0
:for directive :in (cdr form) :do
(if (configuration-inheritance-directive-p directive)
(incf inherit)
(funcall directive-validator directive))
:finally
(unless (= inherit 1)
(error "One and only one of ~S or ~S is required"
:inherit-configuration :ignore-inherited-configuration)))
form)
(defun* validate-configuration-file (file validator description)
Francois-Rene Rideau
committed
(let ((forms (read-file-forms file)))
(unless (length=n-p forms 1)
(error "One and only one form allowed for ~A. Got: ~S~%" description forms))
(funcall validator (car forms))))
(defun* hidden-file-p (pathname)
(equal (first-char (pathname-name pathname)) #\.))
(defun* validate-configuration-directory (directory tag validator)
Francois-Rene Rideau
committed
(let ((files (sort (ignore-errors
(remove-if
'hidden-file-p
(directory (make-pathname :name :wild :type "conf" :defaults directory)
#+sbcl :resolve-symlinks #+sbcl nil)))
Francois-Rene Rideau
committed
#'string< :key #'namestring)))
`(,tag
,@(loop :for file :in files :append
(mapcar validator (read-file-forms file)))
:inherit-configuration)))
;;; ---------------------------------------------------------------------------
;;; asdf-output-translations
;;;
;;; this code is heavily inspired from
;;; asdf-binary-translations, common-lisp-controller and cl-launch.
;;; ---------------------------------------------------------------------------
(defvar *output-translations* ()
"Either NIL (for uninitialized), or a list of one element,
said element itself being a sorted list of mappings.
Each mapping is a pair of a source pathname and destination pathname,
and the order is by decreasing length of namestring of the source pathname.")
(flet ((try (x &rest sub) (and x `(,x ,@sub))))
(or
(try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
#+(and (or win32 windows mswindows mingw32) (not cygwin))
(try (getenv "APPDATA") "common-lisp" "cache" :implementation)
'(:home ".cache" "common-lisp" :implementation))))
;; No good default, plus there's a security problem
;; with other users messing with such directories.
*user-cache*)
Francois-Rene Rideau
committed
(defun* output-translations ()
Francois-Rene Rideau
committed
(car *output-translations*))
(defun* (setf output-translations) (new-value)
Francois-Rene Rideau
committed
(setf *output-translations*
(list
Francois-Rene Rideau
committed
:key (lambda (x)
(etypecase (car x)
((eql t) -1)
(pathname
(length (pathname-directory (car x)))))))))
new-value)
Francois-Rene Rideau
committed
(defun* output-translations-initialized-p ()
Francois-Rene Rideau
committed
(and *output-translations* t))
(defun* clear-output-translations ()
Francois-Rene Rideau
committed
"Undoes any initialization of the output translations.
You might want to call that before you dump an image that would be resumed
with a different configuration, so the configuration would be re-read then."
(setf *output-translations* '())
(values))
(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
(values (or null pathname) &optional))
Francois-Rene Rideau
committed
resolve-location))
(defun* resolve-relative-location-component (super x &key directory wilden)
Francois-Rene Rideau
committed
(let* ((r (etypecase x
(pathname x)
(string x)
(cons
(return-from resolve-relative-location-component
Francois-Rene Rideau
committed
(if (null (cdr x))
(resolve-relative-location-component
super (car x) :directory directory :wilden wilden)
(let* ((car (resolve-relative-location-component
super (car x) :directory t :wilden nil))
(cdr (resolve-relative-location-component
(merge-pathnames* car super) (cdr x)
:directory directory :wilden wilden)))
Francois-Rene Rideau
committed
(merge-pathnames* cdr car)))))
((eql :default-directory)
(relativize-pathname-directory (default-directory)))
((eql :implementation) (implementation-identifier))
((eql :implementation-type) (string-downcase (implementation-type)))
#-(and (or win32 windows mswindows mingw32) (not cygwin))
((eql :uid) (princ-to-string (get-uid)))))
(d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
(s (if (or (pathnamep x) (not wilden)) d (wilden d))))
Francois-Rene Rideau
committed
(when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
(error "pathname ~S is not relative to ~S" s super))
(merge-pathnames* s super)))
Francois-Rene Rideau
committed
(defun* resolve-absolute-location-component (x &key directory wilden)
Francois-Rene Rideau
committed
(let* ((r
(etypecase x
(pathname x)
(string (if directory (ensure-directory-pathname x) (parse-namestring x)))
Francois-Rene Rideau
committed
(cons
(return-from resolve-absolute-location-component
Francois-Rene Rideau
committed
(if (null (cdr x))
(resolve-absolute-location-component
(car x) :directory directory :wilden wilden)
(let* ((car (resolve-absolute-location-component
(car x) :directory t :wilden nil))
(cdr (resolve-relative-location-component
car (cdr x) :directory directory :wilden wilden)))
(merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?
Francois-Rene Rideau
committed
((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
(let ((p (make-pathname :directory '(:relative))))
(if wilden (wilden p) p))))
((eql :home) (user-homedir))
((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
Francois-Rene Rideau
committed
((eql :default-directory) (default-directory))))
(s (if (and wilden (not (pathnamep x)))
Francois-Rene Rideau
committed
(wilden r)
r)))
Francois-Rene Rideau
committed
(unless (absolute-pathname-p s)
(error "Not an absolute pathname ~S" s))
s))
(defun* resolve-location (x &key directory wilden)
(resolve-absolute-location-component x :directory directory :wilden wilden)
(loop :with path = (resolve-absolute-location-component
(car x) :directory (and (or directory (cdr x)) t)
:wilden (and wilden (null (cdr x))))
:for dir = (and (or morep directory) t)
:for wild = (and wilden (not morep))
:do (setf path (resolve-relative-location-component
path component :directory dir :wilden wild))
Francois-Rene Rideau
committed
(defun* location-designator-p (x)
Francois-Rene Rideau
committed
(flet ((componentp (c) (typep c '(or string pathname keyword))))
Francois-Rene Rideau
committed
(or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
Francois-Rene Rideau
committed
(defun* location-function-p (x)
Francois-Rene Rideau
committed
(and
(consp x)
(length=n-p x 2)
(or (and (equal (first x) :function)
(typep (second x) 'symbol))
(and (equal (first x) 'lambda)
(cddr x)
(length=n-p (second x) 2)))))
(defun* validate-output-translations-directive (directive)
Francois-Rene Rideau
committed
(unless
(or (member directive '(:inherit-configuration
:ignore-inherited-configuration
Francois-Rene Rideau
committed
:enable-user-cache :disable-cache nil))
Francois-Rene Rideau
committed
(and (consp directive)
(or (and (length=n-p directive 2)
(or (and (eq (first directive) :include)
(typep (second directive) '(or string pathname null)))
Francois-Rene Rideau
committed
(and (location-designator-p (first directive))
Francois-Rene Rideau
committed
(or (location-designator-p (second directive))
(location-function-p (second directive))))))
Francois-Rene Rideau
committed
(and (length=n-p directive 1)
(location-designator-p (first directive))))))
(error "Invalid directive ~S~%" directive))
directive)
(defun* validate-output-translations-form (form)
Francois-Rene Rideau
committed
(validate-configuration-form
form
:output-translations
'validate-output-translations-directive
"output translations"))
(defun* validate-output-translations-file (file)
Francois-Rene Rideau
committed
(validate-configuration-file
file 'validate-output-translations-form "output translations"))
(defun* validate-output-translations-directory (directory)
Francois-Rene Rideau
committed
(validate-configuration-directory
directory :output-translations 'validate-output-translations-directive))
(defun* parse-output-translations-string (string)
Francois-Rene Rideau
committed
(cond
((or (null string) (equal string ""))
'(:output-translations :inherit-configuration))
((not (stringp string))
(error "environment string isn't: ~S" string))
Francois-Rene Rideau
committed
((eql (char string 0) #\")
(parse-output-translations-string (read-from-string string)))
((eql (char string 0) #\()
Francois-Rene Rideau
committed
(validate-output-translations-form (read-from-string string)))
(t
(loop
:with inherit = nil
:with directives = ()
:with start = 0
:with end = (length string)
:with source = nil
Francois-Rene Rideau
committed
:for i = (or (position *inter-directory-separator* string :start start) end) :do
Francois-Rene Rideau
committed
(let ((s (subseq string start i)))
(cond
(source
(push (list source (if (equal "" s) nil s)) directives)
(setf source nil))
((equal "" s)
(when inherit
(error "only one inherited configuration allowed: ~S" string))
(setf inherit t)
(push :inherit-configuration directives))
Francois-Rene Rideau
committed
(t
(setf source s)))
(setf start (1+ i))
Francois-Rene Rideau
committed
(when (> start end)
Francois-Rene Rideau
committed
(when source
(error "Uneven number of components in source to destination mapping ~S" string))
(unless inherit
(push :ignore-inherited-configuration directives))
Francois-Rene Rideau
committed
(return `(:output-translations ,@(nreverse directives)))))))))
(defparameter *default-output-translations*
Francois-Rene Rideau
committed
user-output-translations-pathname
user-output-translations-directory-pathname
system-output-translations-pathname
system-output-translations-directory-pathname))
(defun* wrapping-output-translations ()
Francois-Rene Rideau
committed
`(:output-translations
;; Some implementations have precompiled ASDF systems,
;; so we must disable translations for implementation paths.
Francois-Rene Rideau
committed
#+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ())))
#+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
Francois-Rene Rideau
committed
#+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
;; All-import, here is where we want user stuff to be:
:inherit-configuration
Francois-Rene Rideau
committed
;; These are for convenience, and can be overridden by the user:
#+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
#+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
Francois-Rene Rideau
committed
;; We enable the user cache by default, and here is the place we do:
:enable-user-cache))
Francois-Rene Rideau
committed
(defparameter *output-translations-file* #p"asdf-output-translations.conf")
(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
Francois-Rene Rideau
committed
(defun* user-output-translations-pathname ()
(in-user-configuration-directory *output-translations-file* ))
(defun* system-output-translations-pathname ()
(in-system-configuration-directory *output-translations-file*))
(defun* user-output-translations-directory-pathname ()
(in-user-configuration-directory *output-translations-directory*))
(defun* system-output-translations-directory-pathname ()
(in-system-configuration-directory *output-translations-directory*))
(defun* environment-output-translations ()
Francois-Rene Rideau
committed
(getenv "ASDF_OUTPUT_TRANSLATIONS"))
(defgeneric* process-output-translations (spec &key inherit collect))
(declaim (ftype (function (t &key (:collect (or symbol function))) t)
Francois-Rene Rideau
committed
inherit-output-translations))
(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)
Francois-Rene Rideau
committed
process-output-translations-directive))
Francois-Rene Rideau
committed
(defmethod process-output-translations ((x symbol) &key
(inherit *default-output-translations*)
collect)
(process-output-translations (funcall x) :inherit inherit :collect collect))
(defmethod process-output-translations ((pathname pathname) &key inherit collect)
Francois-Rene Rideau
committed
(cond
((directory-pathname-p pathname)
(process-output-translations (validate-output-translations-directory pathname)
:inherit inherit :collect collect))
((probe-file pathname)
(process-output-translations (validate-output-translations-file pathname)
:inherit inherit :collect collect))
(t
(inherit-output-translations inherit :collect collect))))
(defmethod process-output-translations ((string string) &key inherit collect)
Francois-Rene Rideau
committed
(process-output-translations (parse-output-translations-string string)
:inherit inherit :collect collect))
(defmethod process-output-translations ((x null) &key inherit collect)
Francois-Rene Rideau
committed
(inherit-output-translations inherit :collect collect))
(defmethod process-output-translations ((form cons) &key inherit collect)
(dolist (directive (cdr (validate-output-translations-form form)))
(process-output-translations-directive directive :inherit inherit :collect collect)))
Francois-Rene Rideau
committed
(defun* inherit-output-translations (inherit &key collect)
Francois-Rene Rideau
committed
(when inherit
(process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
(defun* process-output-translations-directive (directive &key inherit collect)
Francois-Rene Rideau
committed
(if (atom directive)
(ecase directive
((:enable-user-cache)
Francois-Rene Rideau
committed
(process-output-translations-directive '(t :user-cache) :collect collect))
Francois-Rene Rideau
committed
((:disable-cache)
Francois-Rene Rideau
committed
(process-output-translations-directive '(t t) :collect collect))
Francois-Rene Rideau
committed
((:inherit-configuration)
(inherit-output-translations inherit :collect collect))
Francois-Rene Rideau
committed
((:ignore-inherited-configuration nil)
Francois-Rene Rideau
committed
nil))
(let ((src (first directive))
(dst (second directive)))
(if (eq src :include)
(when dst
(process-output-translations (pathname dst) :inherit nil :collect collect))
Francois-Rene Rideau
committed
(when src
(let ((trusrc (or (eql src t)
(let ((loc (resolve-location src :directory t :wilden t)))
(if (absolute-pathname-p loc) (truenamize loc) loc)))))
Francois-Rene Rideau
committed
(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
:defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
(wilddst (make-pathname
:name :wild :type :wild :version :wild
:defaults trudst)))
Francois-Rene Rideau
committed
(funcall collect (list wilddst t))
(funcall collect (list trusrc trudst)))))))))))
Francois-Rene Rideau
committed
(defun* compute-output-translations (&optional parameter)