Skip to content
Snippets Groups Projects
asdf.lisp 148 KiB
Newer Older
  "read the configuration, return it"
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
  (remove-duplicates
   (while-collecting (c)
     (inherit-output-translations
      `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
(defun* initialize-output-translations (&optional parameter)
  "read the configuration, initialize the internal configuration variable,
return the configuration"
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
  (setf (output-translations) (compute-output-translations parameter)))
(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)))

;; 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 ()
  (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)
     (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)
(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))
(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))))

  (make-pathname
   :name (format nil "ASDF-TMP-~A" (pathname-name x))
   :defaults x))

(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)
        (failure-p
         (setf status *compile-file-failure-behaviour*))
        (warnings-p
         (setf status *compile-file-warnings-behaviour*))
         (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))))
(defun* translate-jar-pathname (source wildcard)
  (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))
;;;; -----------------------------------------------------------------
;;;; Compatibility mode for ASDF-Binary-Locations

(defun* enable-asdf-binary-locations-compatibility
    (&key
     (centralize-lisp-binaries nil)
     (default-toplevel-directory
         ;; Use ".cache/common-lisp" instead ???
         (merge-pathnames* (make-pathname :directory '(:relative ".fasls"))
     (map-all-source-files (or #+(or ecl clisp) t nil))
    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
  (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
                        :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))))
                :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))
;;;; -----------------------------------------------------------------
;;;; Windows shortcut support.  Based on:
;;;;
;;;; Jesse Hager: The Windows Shortcut File Format.
;;;; http://www.wotsit.org/list.asp?fc=13
#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
(progn
D Herring's avatar
D Herring committed
(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)
D Herring's avatar
D Herring committed
  (with-output-to-string (out)
    (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))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
        (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
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
        ((logbitp 0 fli-flags)
          (file-position s (+ start local-offset)))
        ((logbitp 1 fli-flags)
          (file-position s (+ start
                              network-volume-offset
                              #x14))))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
        (read-null-terminated-string s)
        (progn
          (file-position s (+ start remaining-offset))
          (read-null-terminated-string s))))))
(defun* parse-windows-shortcut (pathname)
D Herring's avatar
D Herring committed
  (with-open-file (s pathname :element-type '(unsigned-byte 8))
    (handler-case
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
        (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)))))))
D Herring's avatar
D Herring committed
      (end-of-file ()
;;;; -----------------------------------------------------------------
;;;; 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* (setf source-registry) (new-value)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
  (setf *source-registry* (list new-value))
  new-value)
(defun* source-registry-initialized-p ()
  "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))
(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)
  (let* ((directory (ensure-directory-pathname directory))
         #-cormanlisp
         (wild (merge-pathnames*
                (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
                #+(or abcl allegro lispworks scl) "*.*"
                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))
         (dirs (remove-if-not #+abcl #'extensions:probe-directory
                              #+allegro #'excl:probe-directory
                              #+lispworks #'lw:file-directory-p
                              #-(or abcl allegro lispworks) #'directory-pathname-p
(defun collect-sub*directories (directory collectp recursep collector)
  (when (funcall collectp directory)
    (funcall collector directory))
  (dolist (subdir (subdirectories directory))
    (when (funcall recursep subdir)
      (collect-sub*directories subdir collectp recursep collector))))

(defun collect-sub*directories-with-asd
    (directory &key
     (exclude *default-source-registry-exclusions*)
     collect)
  (collect-sub*directories
   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)
      (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))))
               (every #'stringp rest))
              (null rest))))
    (error "Invalid directive ~S~%" directive))
(defun* validate-source-registry-form (form)
  (validate-configuration-form
   form :source-registry 'validate-source-registry-directive "a source registry"))
(defun* validate-source-registry-file (file)
  (validate-configuration-file
   file 'validate-source-registry-form "a source registry"))
(defun* validate-source-registry-directory (directory)
  (validate-configuration-directory
   directory :source-registry 'validate-source-registry-directive))
(defun* parse-source-registry-string (string)
  (cond
    ((or (null string) (equal string ""))
     '(:source-registry :inherit-configuration))
    ((not (stringp string))
     (error "environment string isn't: ~S" string))
    ((find (char string 0) "\"(")
     (validate-source-registry-form (read-from-string string)))
    (t
      :with inherit = nil
      :with directives = ()
      :with start = 0
      :with end = (length string)
      :for pos = (position *inter-directory-separator* string :start start) :do
      (let ((s (subseq string start (or pos end))))
          (when inherit
            (error "only one inherited configuration allowed: ~S" string))
          (setf inherit t)
          (push ':inherit-configuration directives))
         ((ends-with s "//")
          (push `(:tree ,(subseq s 0 (1- (length s)))) directives))
         (t
          (push `(:directory ,s) directives)))
           (unless inherit
             (push '(:ignore-inherited-configuration) directives))
           (return `(:source-registry ,@(nreverse directives))))))))))
(defun* register-asd-directory (directory &key recurse exclude collect)
  (if (not recurse)
      (funcall collect directory)
      (collect-sub*directories-with-asd
       directory :exclude exclude :collect collect)))
  '(environment-source-registry
    user-source-registry
    user-source-registry-directory
    system-source-registry
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
    system-source-registry-directory
    default-source-registry))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
(defparameter *source-registry-file* #p"source-registry.conf")
(defparameter *source-registry-directory* #p"source-registry.conf.d/")
(defun* wrapping-source-registry ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
  `(:source-registry
    #+sbcl (:tree ,(getenv "SBCL_HOME"))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
  (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
    `(:source-registry
      #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
      (:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
      ,@(let*
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
         ((datahome
           (or (getenv "XDG_DATA_HOME")
               (try (user-homedir) ".local/share/")))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
          (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"))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
          (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)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
         (loop :for dir :in dirs
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
           :collect `(:directory ,(try dir "common-lisp/systems/"))
           :collect `(:tree ,(try dir "common-lisp/source/"))))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
      :inherit-configuration)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
  (in-user-configuration-directory *source-registry-file*))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
  (in-system-configuration-directory *source-registry-file*))
(defun* user-source-registry-directory ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
  (in-user-configuration-directory *source-registry-directory*))
(defun* system-source-registry-directory ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
  (in-system-configuration-directory *source-registry-directory*))
(defun* environment-source-registry ()
(defgeneric* process-source-registry (spec &key inherit register))
(declaim (ftype (function (t &key (:register (or symbol function))) t)
(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
(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)
  (process-source-registry (parse-source-registry-string string)
                           :inherit inherit :register register))
(defmethod process-source-registry ((x null) &key inherit register)
  (declare (ignorable x))
  (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))))
(defun* inherit-source-registry (inherit &key register)
    (process-source-registry (first inherit) :register register :inherit (rest inherit))))
(defun* process-source-registry-directive (directive &key inherit register)
  (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
    (ecase kw
      ((:include)
       (destructuring-bind (pathname) rest
         (process-source-registry (resolve-location pathname) :inherit nil :register register)))
           (funcall register (resolve-location pathname :directory t)))))
           (funcall register (resolve-location pathname :directory t)
                    :recurse t :exclude *source-registry-exclusions*))))
       (setf *source-registry-exclusions* rest))
      ((:also-exclude)
       (appendf *source-registry-exclusions* rest))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
       (inherit-source-registry '(default-source-registry) :register register))
       (inherit-source-registry inherit :register register))
(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)))))
;; 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)
  (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))

;;;; -----------------------------------------------------------------
;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
(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*))))

;;;; -------------------------------------------------------------------------
;;;; 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
(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))))))
;;;; -----------------------------------------------------------------
;;;; Done!
(when *load-verbose*
  (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
(eval-when (:compile-toplevel :execute)
  (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
    (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))

(pushnew :asdf2 *features*)