Newer
Older
"read the configuration, return it"
(remove-duplicates
(while-collecting (c)
(inherit-output-translations
`(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
:test 'equal :from-end t))
(defun* initialize-output-translations (&optional parameter)
"read the configuration, initialize the internal configuration variable,
return the configuration"
(setf (output-translations) (compute-output-translations parameter)))
Francois-Rene Rideau
committed
(defun* disable-output-translations ()
"Initialize output translations in a way that maps every file to itself,
effectively disabling the output translation facility."
(initialize-output-translations
'(:output-translations :disable-cache :ignore-inherited-configuration)))
Francois-Rene Rideau
committed
;; checks an initial variable to see whether the state is initialized
;; or cleared. In the former case, return current configuration; in
;; the latter, initialize. ASDF will call this function at the start
;; of (asdf:find-system).
(defun* ensure-output-translations ()
Francois-Rene Rideau
committed
(if (output-translations-initialized-p)
(output-translations)
(initialize-output-translations)))
(defun* translate-pathname* (path absolute-source destination &optional root source)
(declare (ignore source))
(cond
((functionp destination)
(funcall destination path absolute-source))
((eq destination t)
path)
((not (pathnamep destination))
(error "invalid destination"))
((not (absolute-pathname-p destination))
(translate-pathname path absolute-source (merge-pathnames* destination root)))
(root
(translate-pathname (directorize-pathname-host-device path) absolute-source destination))
(t
(translate-pathname path absolute-source destination))))
(defun* apply-output-translations (path)
(etypecase path
(logical-pathname
path)
((or pathname string)
(ensure-output-translations)
Francois-Rene Rideau
committed
(loop :with p = (truenamize path)
:for (source destination) :in (car *output-translations*)
:for root = (when (or (eq source t)
(and (pathnamep source)
(not (absolute-pathname-p source))))
(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 (translate-pathname* p absolute-source destination root source)
Francois-Rene Rideau
committed
:finally (return p)))))
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
(defmethod output-files :around (operation component)
"Translate output files, unless asked not to"
(declare (ignorable operation component))
(values
(multiple-value-bind (files fixedp) (call-next-method)
(if fixedp
files
(mapcar #'apply-output-translations files)))
t))
Francois-Rene Rideau
committed
(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
(or output-file
(apply-output-translations
(apply 'compile-file-pathname
(truenamize (lispize-pathname input-file))
keys))))
(defun* tmpize-pathname (x)
(make-pathname
:name (format nil "ASDF-TMP-~A" (pathname-name x))
:defaults x))
(defun* delete-file-if-exists (x)
(when (and x (probe-file x))
(delete-file x)))
Francois-Rene Rideau
committed
(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
(let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
(tmp-file (tmpize-pathname output-file))
(status :error))
(multiple-value-bind (output-truename warnings-p failure-p)
(apply 'compile-file input-file :output-file tmp-file keys)
(cond
(failure-p
(setf status *compile-file-failure-behaviour*))
(warnings-p
(setf status *compile-file-warnings-behaviour*))
(t
(setf status :success)))
(ecase status
((:success :warn :ignore)
(delete-file-if-exists output-file)
(when output-truename
(rename-file output-truename output-file)
(setf output-truename output-file)))
(:error
(delete-file-if-exists output-truename)
(setf output-truename nil)))
(values output-truename warnings-p failure-p))))
Francois-Rene Rideau
committed
#+abcl
(defun* translate-jar-pathname (source wildcard)
Francois-Rene Rideau
committed
(declare (ignore wildcard))
Francois-Rene Rideau
committed
(let* ((p (pathname (first (pathname-device source))))
(root (format nil "/___jar___file___root___/~@[~A/~]"
(and (find :windows *features*)
(pathname-device p)))))
(apply-output-translations
(merge-pathnames*
(relativize-pathname-directory source)
(merge-pathnames*
(relativize-pathname-directory (ensure-directory-pathname p))
Francois-Rene Rideau
committed
root)))))
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
;;;; -----------------------------------------------------------------
;;;; Compatibility mode for ASDF-Binary-Locations
(defun* enable-asdf-binary-locations-compatibility
Francois-Rene Rideau
committed
(&key
(centralize-lisp-binaries nil)
(default-toplevel-directory
;; Use ".cache/common-lisp" instead ???
(merge-pathnames* (make-pathname :directory '(:relative ".fasls"))
(user-homedir)))
Francois-Rene Rideau
committed
(include-per-user-information nil)
Francois-Rene Rideau
committed
(map-all-source-files (or #+(or ecl clisp) t nil))
Francois-Rene Rideau
committed
(source-to-target-mappings nil))
Francois-Rene Rideau
committed
#+(or ecl clisp)
(when (null map-all-source-files)
Francois-Rene Rideau
committed
(error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
Francois-Rene Rideau
committed
(let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
(wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
(mapped-files (make-pathname
:name :wild :version :wild
Francois-Rene Rideau
committed
:type (if map-all-source-files :wild fasl-type)))
(destination-directory
(if centralize-lisp-binaries
`(,default-toplevel-directory
,@(when include-per-user-information
(cdr (pathname-directory (user-homedir))))
Francois-Rene Rideau
committed
:implementation ,wild-inferiors)
`(:root ,wild-inferiors :implementation))))
(initialize-output-translations
`(:output-translations
,@source-to-target-mappings
((:root ,wild-inferiors ,mapped-files)
(,@destination-directory ,mapped-files))
Francois-Rene Rideau
committed
(t t)
Francois-Rene Rideau
committed
:ignore-inherited-configuration))))
;;;; -----------------------------------------------------------------
;;;; Windows shortcut support. Based on:
;;;;
;;;; Jesse Hager: The Windows Shortcut File Format.
;;;; http://www.wotsit.org/list.asp?fc=13
Francois-Rene Rideau
committed
#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
(progn
(defparameter *link-initial-dword* 76)
(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
(defun* read-null-terminated-string (s)
(loop :for code = (read-byte s)
:until (zerop code)
:do (write-char (code-char code) out))))
(defun* read-little-endian (s &optional (bytes 4))
(loop
:for i :from 0 :below bytes
:sum (ash (read-byte s) (* 8 i))))
(defun* parse-file-location-info (s)
(let ((start (file-position s))
(total-length (read-little-endian s))
(end-of-header (read-little-endian s))
(fli-flags (read-little-endian s))
(local-volume-offset (read-little-endian s))
(local-offset (read-little-endian s))
(network-volume-offset (read-little-endian s))
(remaining-offset (read-little-endian s)))
(declare (ignore total-length end-of-header local-volume-offset))
(unless (zerop fli-flags)
(cond
((logbitp 0 fli-flags)
(file-position s (+ start local-offset)))
((logbitp 1 fli-flags)
(file-position s (+ start
network-volume-offset
#x14))))
(concatenate 'string
(read-null-terminated-string s)
(progn
(file-position s (+ start remaining-offset))
(read-null-terminated-string s))))))
(defun* parse-windows-shortcut (pathname)
(with-open-file (s pathname :element-type '(unsigned-byte 8))
(handler-case
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
(when (and (= (read-little-endian s) *link-initial-dword*)
(let ((header (make-array (length *link-guid*))))
(read-sequence header s)
(equalp header *link-guid*)))
(let ((flags (read-little-endian s)))
(file-position s 76) ;skip rest of header
(when (logbitp 0 flags)
;; skip shell item id list
(let ((length (read-little-endian s 2)))
(file-position s (+ length (file-position s)))))
(cond
((logbitp 1 flags)
(parse-file-location-info s))
(t
(when (logbitp 2 flags)
;; skip description string
(let ((length (read-little-endian s 2)))
(file-position s (+ length (file-position s)))))
(when (logbitp 3 flags)
;; finally, our pathname
(let* ((length (read-little-endian s 2))
(buffer (make-array length)))
(read-sequence buffer s)
(map 'string #'code-char buffer)))))))
Francois-Rene Rideau
committed
nil)))))
Francois-Rene Rideau
committed
;;;; -----------------------------------------------------------------
;;;; Source Registry Configuration, by Francois-Rene Rideau
;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
;; Using ack 1.2 exclusions
(defvar *default-source-registry-exclusions*
'(".bzr" ".cdv"
;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
"_sgbak" "autom4te.cache" "cover_db" "_build"
"debian")) ;; debian often build stuff under the debian directory... BAD.
(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
(defvar *source-registry* ()
"Either NIL (for uninitialized), or a list of one element,
said element itself being a list of directory pathnames where to look for .asd files")
(defun* source-registry ()
(car *source-registry*))
(defun* (setf source-registry) (new-value)
(setf *source-registry* (list new-value))
new-value)
(defun* source-registry-initialized-p ()
(and *source-registry* t))
(defun* clear-source-registry ()
"Undoes any initialization of the source registry.
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 *source-registry* '())
(values))
Francois-Rene Rideau
committed
(defparameter *wild-asd*
(make-pathname :directory nil :name :wild :type "asd" :version :newest))
(defun directory-has-asd-files-p (directory)
(and (ignore-errors
(directory (merge-pathnames* *wild-asd* directory)
#+sbcl #+sbcl :resolve-symlinks nil
#+ccl #+ccl :follow-links nil
#+clisp #+clisp :circle t))
t))
(defun subdirectories (directory)
Francois-Rene Rideau
committed
(let* ((directory (ensure-directory-pathname directory))
#-cormanlisp
(wild (merge-pathnames*
#-(or abcl allegro lispworks scl)
Francois-Rene Rideau
committed
(make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
#+(or abcl allegro lispworks scl) "*.*"
Francois-Rene Rideau
committed
directory))
(dirs
#-cormanlisp
(ignore-errors
(directory wild .
#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
#+ccl '(:follow-links nil :directories t :files nil)
#+clisp '(:circle t :if-does-not-exist :ignore)
#+(or cmu scl) '(:follow-links nil :truenamep nil)
#+digitool '(:directories t)
#+sbcl '(:resolve-symlinks nil))))
#+cormanlisp (cl::directory-subdirs directory))
#+(or abcl allegro lispworks scl)
Francois-Rene Rideau
committed
(dirs (remove-if-not #+abcl #'extensions:probe-directory
#+allegro #'excl:probe-directory
#+lispworks #'lw:file-directory-p
#-(or abcl allegro lispworks) #'directory-pathname-p
Francois-Rene Rideau
committed
dirs)))
dirs))
Francois-Rene Rideau
committed
(defun collect-sub*directories (directory collectp recursep collector)
Francois-Rene Rideau
committed
(when (funcall collectp directory)
(funcall collector directory))
(dolist (subdir (subdirectories directory))
(when (funcall recursep subdir)
(collect-sub*directories subdir collectp recursep collector))))
Francois-Rene Rideau
committed
(defun collect-sub*directories-with-asd
(directory &key
(exclude *default-source-registry-exclusions*)
collect)
(collect-sub*directories
Francois-Rene Rideau
committed
directory
#'directory-has-asd-files-p
#'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
collect))
(defun* validate-source-registry-directive (directive)
Francois-Rene Rideau
committed
(or (member directive '(:default-registry (:default-registry)) :test 'equal)
(destructuring-bind (kw &rest rest) directive
(case kw
((:include :directory :tree)
(and (length=n-p rest 1)
(location-designator-p (first rest))))
((:exclude :also-exclude)
Francois-Rene Rideau
committed
(every #'stringp rest))
(null rest))))
(error "Invalid directive ~S~%" directive))
Francois-Rene Rideau
committed
(defun* validate-source-registry-form (form)
Francois-Rene Rideau
committed
(validate-configuration-form
form :source-registry 'validate-source-registry-directive "a source registry"))
Francois-Rene Rideau
committed
(defun* validate-source-registry-file (file)
Francois-Rene Rideau
committed
(validate-configuration-file
file 'validate-source-registry-form "a source registry"))
Francois-Rene Rideau
committed
(defun* validate-source-registry-directory (directory)
Francois-Rene Rideau
committed
(validate-configuration-directory
directory :source-registry 'validate-source-registry-directive))
(defun* parse-source-registry-string (string)
(cond
((or (null string) (equal string ""))
Francois-Rene Rideau
committed
'(:source-registry :inherit-configuration))
Francois-Rene Rideau
committed
((not (stringp string))
(error "environment string isn't: ~S" string))
((find (char string 0) "\"(")
Francois-Rene Rideau
committed
(validate-source-registry-form (read-from-string string)))
(t
Francois-Rene Rideau
committed
:with inherit = nil
:with directives = ()
:with start = 0
:with end = (length string)
Francois-Rene Rideau
committed
:for pos = (position *inter-directory-separator* string :start start) :do
(let ((s (subseq string start (or pos end))))
Francois-Rene Rideau
committed
(cond
Francois-Rene Rideau
committed
((equal "" s) ; empty element: inherit
Francois-Rene Rideau
committed
(when inherit
(error "only one inherited configuration allowed: ~S" string))
(setf inherit t)
Francois-Rene Rideau
committed
(push ':inherit-configuration directives))
Francois-Rene Rideau
committed
((ends-with s "//")
(push `(:tree ,(subseq s 0 (1- (length s)))) directives))
(t
(push `(:directory ,s) directives)))
(cond
(pos
(setf start (1+ pos)))
(t
Francois-Rene Rideau
committed
(unless inherit
(push '(:ignore-inherited-configuration) directives))
(return `(:source-registry ,@(nreverse directives))))))))))
Francois-Rene Rideau
committed
(defun* register-asd-directory (directory &key recurse exclude collect)
(if (not recurse)
(funcall collect directory)
Francois-Rene Rideau
committed
(collect-sub*directories-with-asd
directory :exclude exclude :collect collect)))
Francois-Rene Rideau
committed
(defparameter *default-source-registries*
Francois-Rene Rideau
committed
'(environment-source-registry
user-source-registry
user-source-registry-directory
system-source-registry
system-source-registry-directory
default-source-registry))
Francois-Rene Rideau
committed
(defparameter *source-registry-file* #p"source-registry.conf")
(defparameter *source-registry-directory* #p"source-registry.conf.d/")
Francois-Rene Rideau
committed
(defun* wrapping-source-registry ()
`(:source-registry
#+sbcl (:tree ,(getenv "SBCL_HOME"))
Francois-Rene Rideau
committed
:inherit-configuration
#+cmu (:tree #p"modules:")))
(defun* default-source-registry ()
(flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
`(:source-registry
#+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
(:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
#+(or unix cygwin)
(try (user-homedir) ".local/share/")))
(datadirs
(or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
(dirs (cons datahome (split-string datadirs :separator ":"))))
#+(and (or win32 windows mswindows mingw32) (not cygwin))
((datahome (getenv "APPDATA"))
(datadir
#+lispworks (sys:get-folder-path :local-appdata)
#-lispworks (try (getenv "ALLUSERSPROFILE")
"Application Data"))
(dirs (list datahome datadir)))
#-(or unix win32 windows mswindows mingw32 cygwin)
((dirs ()))
:collect `(:directory ,(try dir "common-lisp/systems/"))
:collect `(:tree ,(try dir "common-lisp/source/"))))
(defun* user-source-registry ()
(in-user-configuration-directory *source-registry-file*))
(defun* system-source-registry ()
(in-system-configuration-directory *source-registry-file*))
(defun* user-source-registry-directory ()
(in-user-configuration-directory *source-registry-directory*))
(defun* system-source-registry-directory ()
(in-system-configuration-directory *source-registry-directory*))
(defun* environment-source-registry ()
Francois-Rene Rideau
committed
(getenv "CL_SOURCE_REGISTRY"))
(defgeneric* process-source-registry (spec &key inherit register))
(declaim (ftype (function (t &key (:register (or symbol function))) t)
Francois-Rene Rideau
committed
inherit-source-registry))
(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
Francois-Rene Rideau
committed
process-source-registry-directive))
(defmethod process-source-registry ((x symbol) &key inherit register)
(process-source-registry (funcall x) :inherit inherit :register register))
(defmethod process-source-registry ((pathname pathname) &key inherit register)
(cond
((directory-pathname-p pathname)
(process-source-registry (validate-source-registry-directory pathname)
:inherit inherit :register register))
((probe-file pathname)
(process-source-registry (validate-source-registry-file pathname)
:inherit inherit :register register))
(inherit-source-registry inherit :register register))))
(defmethod process-source-registry ((string string) &key inherit register)
Francois-Rene Rideau
committed
(process-source-registry (parse-source-registry-string string)
:inherit inherit :register register))
(defmethod process-source-registry ((x null) &key inherit register)
(inherit-source-registry inherit :register register))
(defmethod process-source-registry ((form cons) &key inherit register)
(let ((*source-registry-exclusions* *default-source-registry-exclusions*))
(dolist (directive (cdr (validate-source-registry-form form)))
(process-source-registry-directive directive :inherit inherit :register register))))
Francois-Rene Rideau
committed
(defun* inherit-source-registry (inherit &key register)
Francois-Rene Rideau
committed
(when inherit
(process-source-registry (first inherit) :register register :inherit (rest inherit))))
Francois-Rene Rideau
committed
(defun* process-source-registry-directive (directive &key inherit register)
Francois-Rene Rideau
committed
(destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
Francois-Rene Rideau
committed
(ecase kw
((:include)
(destructuring-bind (pathname) rest
(process-source-registry (resolve-location pathname) :inherit nil :register register)))
Francois-Rene Rideau
committed
((:directory)
(destructuring-bind (pathname) rest
(funcall register (resolve-location pathname :directory t)))))
Francois-Rene Rideau
committed
((:tree)
(destructuring-bind (pathname) rest
(funcall register (resolve-location pathname :directory t)
:recurse t :exclude *source-registry-exclusions*))))
((:exclude)
(setf *source-registry-exclusions* rest))
((:also-exclude)
(appendf *source-registry-exclusions* rest))
Francois-Rene Rideau
committed
((:default-registry)
(inherit-source-registry '(default-source-registry) :register register))
Francois-Rene Rideau
committed
((:inherit-configuration)
(inherit-source-registry inherit :register register))
Francois-Rene Rideau
committed
((:ignore-inherited-configuration)
Francois-Rene Rideau
committed
nil)))
nil)
(defun* flatten-source-registry (&optional parameter)
(remove-duplicates
(while-collecting (collect)
(inherit-source-registry
`(wrapping-source-registry
,parameter
,@*default-source-registries*)
:register (lambda (directory &key recurse exclude)
(collect (list directory :recurse recurse :exclude exclude)))))
:test 'equal :from-end t))
;; Will read the configuration and initialize all internal variables,
;; and return the new configuration.
(defun* compute-source-registry (&optional parameter)
(while-collecting (collect)
(dolist (entry (flatten-source-registry parameter))
(destructuring-bind (directory &key recurse exclude) entry
(register-asd-directory
directory
:recurse recurse :exclude exclude :collect #'collect)))))
(defun* initialize-source-registry (&optional parameter)
(setf (source-registry) (compute-source-registry parameter)))
;; Checks an initial variable to see whether the state is initialized
;; or cleared. In the former case, return current configuration; in
;; the latter, initialize. ASDF will call this function at the start
;; of (asdf:find-system) to make sure the source registry is initialized.
;; However, it will do so *without* a parameter, at which point it
;; will be too late to provide a parameter to this function, though
;; you may override the configuration explicitly by calling
;; initialize-source-registry directly with your parameter.
(defun* ensure-source-registry (&optional parameter)
(if (source-registry-initialized-p)
(source-registry)
(initialize-source-registry parameter)))
(defun* sysdef-source-registry-search (system)
Francois-Rene Rideau
committed
(ensure-source-registry)
(loop :with name = (coerce-name system)
:for defaults :in (source-registry)
:for file = (probe-asd name defaults)
:when file :return file))
(defun* clear-configuration ()
(clear-source-registry)
(clear-output-translations))
Francois-Rene Rideau
committed
;;;; -----------------------------------------------------------------
Francois-Rene Rideau
committed
;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
Francois-Rene Rideau
committed
;;;;
(defun* module-provide-asdf (name)
(handler-bind
((style-warning #'muffle-warning)
(missing-component (constantly nil))
(error (lambda (e)
(format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
name e))))
(let* ((*verbose-out* (make-broadcast-stream))
(system (find-system (string-downcase name) nil)))
(when system
(load-system system)
t))))
#+(or abcl clisp clozure cmu ecl sbcl)
(let ((x (and #+clisp (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" :custom))))
(when x
(eval `(pushnew 'module-provide-asdf
#+abcl sys::*module-provider-functions*
#+clisp ,x
#+clozure ccl:*module-provider-functions*
#+cmu ext:*module-provider-functions*
#+ecl si:*module-provider-functions*
#+sbcl sb-ext:*module-provider-functions*))))
Francois-Rene Rideau
committed
;;;; -------------------------------------------------------------------------
;;;; Cleanups after hot-upgrade.
;;;; Things to do in case we're upgrading from a previous version of ASDF.
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
;;;;
;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1
Francois-Rene Rideau
committed
(eval-when (:compile-toplevel :load-toplevel :execute)
#+ecl ;; Support upgrade from before ECL went to 1.369
(when (fboundp 'compile-op-system-p)
(defmethod compile-op-system-p ((op compile-op))
(getf :system-p (compile-op-flags op)))
(defmethod initialize-instance :after ((op compile-op)
&rest initargs
&key system-p &allow-other-keys)
(declare (ignorable initargs))
(when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))
Francois-Rene Rideau
committed
;;;; -----------------------------------------------------------------
;;;; Done!
(when *load-verbose*
Francois-Rene Rideau
committed
(asdf-message ";; ASDF, version ~a~%" (asdf-version)))
Francois-Rene Rideau
committed
#+allegro
(eval-when (:compile-toplevel :execute)
(when (boundp 'excl:*warn-on-nested-reader-conditionals*)
(setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))
Francois-Rene Rideau
committed
(pushnew :asdf *features*)
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
(provide :asdf)
Francois-Rene Rideau
committed
;;; Local Variables:
;;; mode: lisp
;;; End: