Skip to content
Snippets Groups Projects
asdf.lisp 119 KiB
Newer Older
            (union-of-dependencies
             in-order-to
             `((compile-op (compile-op ,@depends-on))
               (load-op (load-op ,@depends-on))))
            (component-do-first ret) `((compile-op (load-op ,@depends-on))))
Gary King's avatar
Gary King committed
      (%refresh-component-inline-methods ret rest)
;;;; ---------------------------------------------------------------------------
;;;; 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.
;;;; 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
Daniel Barlow's avatar
Daniel Barlow committed
(defun run-shell-command (control-string &rest args)
  "Interpolate `args` into `control-string` as if by `format`, and
synchronously execute the result using a Bourne-compatible shell, with
output to `*verbose-out*`.  Returns the shell's exit code."
Daniel Barlow's avatar
Daniel Barlow committed
  (let ((command (apply #'format nil control-string args)))
    (asdf-message "; $ ~A~%" command)
    (sb-ext:process-exit-code
     (apply #'sb-ext:run-program
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
            #+win32 "sh" #-win32 "/bin/sh"
            (list  "-c" command)
            :input nil :output *verbose-out*
            #+win32 '(:search t) #-win32 nil))
Daniel Barlow's avatar
Daniel Barlow committed
    (ext:process-exit-code
     (ext:run-program
Daniel Barlow's avatar
Daniel Barlow committed
      "/bin/sh"
      (list  "-c" command)
    ;; will this fail if command has embedded quotes - it seems to work
    (multiple-value-bind (stdout stderr exit-code)
        (excl.osi:command-output
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
         (format nil "~a -c \"~a\""
                 #+mswindows "sh" #-mswindows "/bin/sh" command)
         :input nil :whole nil
         #+mswindows :show-window #+mswindows :hide)
      (format *verbose-out* "~{~&; ~a~%~}~%" stderr)
      (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
      exit-code)

    #+lispworks
    (system:call-system-showing-output
     command
     :shell-type "/bin/sh"
     :show-cmd nil
     :prefix ""

    #+clisp                     ;XXX not exactly *verbose-out*, I know
    (ext:run-shell-command  command :output :terminal :wait t)

    #+openmcl
               (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)
    #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl)
    (error "RUN-SHELL-COMMAND not implemented for this Lisp")
;;;; ---------------------------------------------------------------------------
;;;; system-relative-pathname

(defmethod system-source-file ((system-name t))
  (system-source-file (find-system system-name)))

(defun system-source-directory (system-name)
  (make-pathname :name nil
                 :type nil
                 :defaults (system-source-file system-name)))

(defun relativize-directory (directory)
  (if (eq (car directory) :absolute)
      (cons :relative (cdr directory))
      directory))

(defun relativize-pathname-directory (pathspec)
  (let ((p (pathname pathspec)))
    (make-pathname
     :directory (relativize-directory (pathname-directory p))
     :defaults p)))

(defun system-relative-pathname (system pathname &key name type)
  (let ((directory (pathname-directory pathname)))
     (make-pathname :name (or name (pathname-name pathname))
                    :type (or type (pathname-type pathname))
                    :directory (relativize-directory directory))
;;; ---------------------------------------------------------------------------
;;; produce a string to identify current implementation.
;;; Initially stolen from SLIME's SWANK, hacked since.
(defparameter *implementation-features*
  '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp
    :corman :cormanlisp :armedbear :gcl :ecl :scl))

(defparameter *os-features*
  '((:windows :mswindows :win32 :mingw32)
    (:solaris :sunos)
    :macosx :darwin :apple
    :freebsd :netbsd :openbsd :bsd
    :linux :unix))

(defparameter *architecture-features*
  '((:x86-64 :amd64 :x86_64 :x8664-target)
    (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4)
    :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc))

(defun lisp-version-string ()
  (let ((s (lisp-implementation-version)))
    (declare (ignorable s))
    #+(or scl sbcl ecl armedbear cormanlisp mcl) s
    #+cmu (substitute #\- #\/ s)
    #+clozure (format nil "~d.~d~@[-~d~]"
                      ccl::*openmcl-major-version*
                      ccl::*openmcl-minor-version*
                      #-ppc64-target nil)
    #+lispworks (format nil "~A~@[~A~]" s
                        (when (member :lispworks-64bit *features*) "-64bit"))
    #+allegro (format nil
                      "~A~A~A~A"
                      excl::*common-lisp-version-number*
                      ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                      (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
                      (if (member :64bit *features*) "-64bit" ""))
    #+(or clisp gcl) (subseq s 0 (position #\space s))
    #+digitool (subseq s 8)))

(defun first-feature (features)
  (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 ()
  (first-feature *implementation-features*))

(defun implementation-identifier ()
  (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.")))
      (substitute-if
       #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
       (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))



;;; ---------------------------------------------------------------------------
;;; Generic support for configuration files
(defun user-configuration-directory ()
  (merge-pathnames* #p".config/" (user-homedir-pathname)))
(defun system-configuration-directory ()
  #p"/etc/")

(defun configuration-inheritance-directive-p (x)
  (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
                                    &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)
  (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 validate-configuration-directory (directory tag validator)
  (let ((files (sort (ignore-errors
                       (directory (make-pathname :name :wild :type :wild :defaults directory)
                                  #+sbcl :resolve-symlinks #+sbcl nil))
                     #'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.")

(defvar *user-cache* '(:home ".cache" "common-lisp" :implementation))
(defvar *system-cache* '(:root "var" "cache" "common-lisp" :uid :implementation))

(defun output-translations ()
  (car *output-translations*))

(defun (setf output-translations) (x)
  (setf *output-translations*
        (list
         (stable-sort (copy-list x) #'>
                      :key (lambda (x) (length (pathname-directory (car x))))))))

(defun output-translations-initialized-p ()
  (and *output-translations* t))

(defun clear-output-translations ()
  "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))

(defparameter *wild-path*
  (make-pathname :directory '(:relative :wild-inferiors)
                 :name :wild :type :wild :version nil))

(defparameter *wild-asd*
  (make-pathname :directory '(:relative :wild-inferiors)
                 :name :wild :type "asd" :version nil))

(defun wilden (path)
  (merge-pathnames* *wild-path* path))
(defun resolve-absolute-location-component (x wildenp)
  (let* ((r
          (etypecase x
            (pathname x)
            (string (ensure-directory-pathname x))
            ((eql :home) (user-homedir-pathname))
            ((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)))))
         (s (if (and wildenp (not (pathnamep x)))
                (wilden r)
                r)))
    (unless (absolute-pathname-p s)
      (error "Not an absolute pathname ~S" s))
    s))

(defun resolve-relative-location-component (super x &optional wildenp)
  (let* ((r (etypecase x
              (pathname x)
              (string x)
              ((eql :current-directory)
               (relativize-pathname-directory
                (truenamize *default-pathname-defaults*)))
              ((eql :implementation) (implementation-identifier))
              ((eql :implementation-type) (string-downcase (implementation-type)))
              ((eql :uid) (princ-to-string (get-uid)))))
         (d (if (pathnamep x) r (ensure-directory-pathname r)))
         (s (if (and wildenp (not (pathnamep x)))
                (wilden d)
                d)))
    (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
      (error "pathname ~S is not relative to ~S" s super))
(defun resolve-location (x &optional wildenp)
  (if (atom x)
      (resolve-absolute-location-component x wildenp)
      (loop :with path = (resolve-absolute-location-component (car x) nil)
        :for (component . morep) :on (cdr x)
        :do (setf path (resolve-relative-location-component
                        path component (and wildenp (not morep))))
        :finally (return path))))

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

(defun validate-output-translations-directive (directive)
  (unless
      (or (member directive '(:inherit-configuration
                              :ignore-inherited-configuration
                              :enable-user-cache :disable-cache))
          (and (consp directive)
               (or (and (length=n-p directive 2)
                        (or (and (eq (first directive) :include)
                                 (typep (second directive) '(or string pathname null)))
                            (and (location-designator-p (first directive))
                                 (or (location-designator-p (second directive))
                                     (null (second directive))))))
                   (and (length=n-p directive 1)
                        (location-designator-p (first directive))))))
    (error "Invalid directive ~S~%" directive))
  directive)

(defun validate-output-translations-form (form)
  (validate-configuration-form
   form
   :output-translations
   'validate-output-translations-directive
   "output translations"))

(defun validate-output-translations-file (file)
  (validate-configuration-file
   file 'validate-output-translations-form "output translations"))

(defun validate-output-translations-directory (directory)
  (validate-configuration-directory
   directory :output-translations 'validate-output-translations-directive))

(defun parse-output-translations-string (string)
  (cond
    ((or (null string) (equal string ""))
     '(:output-translations :inherit-configuration))
    ((not (stringp string))
     (error "environment string isn't: ~S" string))
    ((find (char string 0) "\"(")
     (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
      :for i = (or (position #\: string :start start) end) :do
      (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))
          (t
           (setf source s)))
        (setf start (1+ i))
        (when (>= start end)
          (when source
            (error "Uneven number of components in source to destination mapping ~S" string))
          (unless inherit
            (push :ignore-inherited-configuration directives))
          (return `(:output-translations ,@(nreverse directives)))))))))

(defparameter *default-output-translations*
  '(implementation-output-translations
    user-output-translations-pathname
    user-output-translations-directory-pathname
    system-output-translations-pathname
    system-output-translations-directory-pathname))

(defparameter *implementation-output-translations*
  `(:output-translations
    ;; Some implementations have precompiled ASDF systems,
    ;; so we must disable translations for implementation paths.
    #+sbcl (,(getenv "SBCL_HOME") ())
    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually.
    #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system
    ;; All-import, here is where we want user stuff to be:
    :inherit-configuration
    ;; If we want to enable the user cache by default, here would be the place:
    :enable-user-cache))

(defun implementation-output-translations ()
  *implementation-output-translations*)

(defparameter *output-translations-file* #p"common-lisp/asdf-output-translations.conf")
(defparameter *output-translations-directory* #p"common-lisp/asdf-output-translations.conf.d/")

(defun user-output-translations-pathname ()
  (merge-pathnames* *output-translations-file* (user-configuration-directory)))
(defun system-output-translations-pathname ()
  (merge-pathnames* *output-translations-file* (system-configuration-directory)))
(defun user-output-translations-directory-pathname ()
  (merge-pathnames* *output-translations-directory* (user-configuration-directory)))
(defun system-output-translations-directory-pathname ()
  (merge-pathnames* *output-translations-directory* (system-configuration-directory)))
(defun environment-output-translations ()
  (getenv "ASDF_OUTPUT_TRANSLATIONS"))

(defgeneric process-output-translations (spec &key inherit collect))
(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 *default-output-translations*)
                                        collect)
  (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 *default-output-translations*)
                                        collect)
  (process-output-translations (parse-output-translations-string string)
                               :inherit inherit :collect collect))
(defmethod process-output-translations ((x null) &key
                                    (inherit *default-output-translations*)
                                    collect)
  (declare (ignorable x))
  (inherit-output-translations inherit :collect collect))
(defmethod process-output-translations ((form cons) &key
                                        (inherit *default-output-translations*)
                                        collect)
  (dolist (directive (cdr (validate-output-translations-form form)))
    (process-output-translations-directive directive :inherit inherit :collect collect)))

(defun inherit-output-translations (inherit &key collect)
  (when inherit
    (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))

(defun process-output-translations-directive (directive &key inherit collect)
  (if (atom directive)
      (ecase directive
        ((:enable-user-cache)
         (process-output-translations-directive '(:root :user-cache) :collect collect))
        ((:disable-cache)
         (process-output-translations-directive '(:root :root) :collect collect))
        ((:inherit-configuration)
         (inherit-output-translations inherit :collect collect))
        ((:ignore-inherited-configuration)
         nil))
      (let ((src (first directive))
            (dst (second directive)))
        (if (eq src :include)
            (when dst
              (process-output-translations (pathname dst) :inherit nil :collect collect))
            (let* ((trusrc (truenamize (resolve-location src t)))
                   (trudst (if dst (resolve-location dst t) trusrc)))
(defun compute-output-translations
    (&optional (translations *default-output-translations*))
  "read the configuration, return it"
  (while-collecting (c)
    (inherit-output-translations translations :collect #'c)))

(defun initialize-output-translations
    (&optional (translations *default-output-translations*))
  "read the configuration, initialize the internal configuration variable,
return the configuration"
  (setf (output-translations) (compute-output-translations translations)))

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

  (etypecase path
    (logical-pathname
     path)
    ((or pathname string)
     (ensure-output-translations)
     (setf path (truenamize path))
     (loop :for (source destination) :in (car *output-translations*)
       :when (pathname-match-p path source)
       :return (translate-pathname path source destination)
       :finally (return path)))))

(defmethod output-files :around ((op operation) (c component))
  "Method to rewrite output files to fasl-root"
  (mapcar #'apply-output-translations (call-next-method)))

(defun compile-file-pathname* (input-file &rest keys)
  (apply-output-translations
   (apply #'compile-file-pathname
          (truenamize (make-pathname :type "lisp" :defaults input-file))

;;;; -----------------------------------------------------------------
;;;; Windows shortcut support.  Based on:
;;;;
;;;; Jesse Hager: The Windows Shortcut File Format.
;;;; http://www.wotsit.org/list.asp?fc=13
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)
  (with-output-to-string (out)
    (loop :for code = (read-byte s)
      :until (zerop code)
      :do (write-char (code-char code) out))))
D Herring's avatar
D Herring committed

(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))))))
D Herring's avatar
D Herring committed
(defun parse-windows-shortcut (pathname)
  (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 ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
        nil))))
;;;; -----------------------------------------------------------------
;;;; Source Registry Configuration, by Francois-Rene Rideau
;;;; See README.source-registry and https://bugs.launchpad.net/asdf/+bug/485918
;; Using ack 1.2 exclusions
(defvar *default-exclusions*
  '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    "_sgbak" "autom4te.cache" "cover_db" "_build"))

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

(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))
(defun sysdef-source-registry-search (system)
  (ensure-source-registry)
  (let ((name (coerce-name system)))
    (block nil
      (dolist (dir (source-registry))
        (let ((defaults (eval dir)))
          (when defaults
            (cond ((directory-pathname-p defaults)
                   (let ((file (and defaults
                                    (make-pathname
                                     :defaults defaults :version :newest
                                     :name name :type "asd" :case :local)))
                         #+(and (or win32 windows) (not :clisp))
                         (shortcut (make-pathname
                                    :defaults defaults :version :newest
                                    :name name :type "asd.lnk" :case :local)))
                     (when (and file (probe-file file))
                       (return file))
                     #+(and (or win32 windows) (not :clisp))
                     (when (probe-file shortcut)
                       (let ((target (parse-windows-shortcut shortcut)))
                         (when target
                           (return (pathname target))))))))))))))

(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)
                    (typep (car rest) '(or pathname string null))))
              ((:exclude)
               (every #'stringp rest))
              (null rest))))
    (error "Invalid directive ~S~%" directive))
  (validate-configuration-form
   form :source-registry 'validate-source-registry-directive "a source registry"))
  (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))
  (cond
    ((or (null string) (equal string ""))
     '(:source-registry :inherit-configuration))
    ((not (stringp string))
     (error "environment string isn't: ~S" string))
    ((eql (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 i = (or (position #\: string :start start) end) :do
      (let ((s (subseq string start i)))
        (cond
          (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)))
         (setf start (1+ i))
         (when (>= start end)
           (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 (ensure-directory-pathname directory))
      (let* ((files (ignore-errors
                      (directory (merge-pathnames* *wild-asd* directory)
                                 #+sbcl #+sbcl :resolve-symlinks nil
                                 #+clisp #+clisp :circle t)))
             (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files)
                                      :test #'equal)))
        (loop
          :for dir :in dirs
          :unless (loop :for x :in exclude
                    :thereis (find x (pathname-directory dir) :test #'equal))
          :do (funcall collect dir)))))
  '(environment-source-registry
    user-source-registry
    user-source-registry-directory
    system-source-registry
    system-source-registry-directory))

(defparameter *source-registry-file* #p"common-lisp/source-registry.conf")
(defparameter *source-registry-directory* #p"common-lisp/source-registry.conf.d/")

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
(defun wrapping-source-registry ()
  `(:source-registry
    #+sbcl (:tree ,(getenv "SBCL_HOME"))
   :inherit-configuration))
(defun default-source-registry ()
  `(:source-registry
    #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir-pathname)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
    (:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
    (:directory ,(merge-pathnames* ".local/share/common-lisp/systems/" (user-homedir-pathname)))
    (:tree ,(merge-pathnames* ".local/share/common-lisp/source/" (user-homedir-pathname)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
    (:directory "/usr/local/share/common-lisp/systems/")
    (:tree "/usr/local/share/common-lisp/source/")
    (:directory "/usr/local/share/common-lisp/systems/")
    (:tree "/usr/local/share/common-lisp/source/")
    (:directory "/usr/share/common-lisp/systems/")
    (:tree "/usr/share/common-lisp/source/")
    :inherit-configuration))
  (merge-pathnames* *source-registry-file* (user-configuration-directory)))
  (merge-pathnames* *source-registry-file* (system-configuration-directory)))
  (merge-pathnames* *source-registry-directory* (user-configuration-directory)))
  (merge-pathnames* *source-registry-directory* (system-configuration-directory)))
(defun environment-source-registry ()
  (getenv "CL_SOURCE_REGISTRY"))
(defgeneric process-source-registry (spec &key inherit register))
(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 ((*default-exclusions* *default-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 (pathname pathname) :inherit nil :register register)))
           (funcall register (pathname pathname)))))
           (funcall register (pathname pathname) :recurse t :exclude *default-exclusions*))))
      ((:exclude)
       (setf *default-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 (registries)
  (while-collecting (collect)
    (inherit-source-registry
     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)
  (let* ((flattened
          (flatten-source-registry
           `(wrapping-source-registry
             ,parameter
             ,@*default-source-registries*
             default-source-registry)))
         (simplified
          (remove-duplicates flattened :test 'equal :from-end nil))
         (processed
          (while-collecting (collect)
            (dolist (entry simplified)
              (destructuring-bind (directory &key recurse exclude) entry
                (register-asd-directory
                 directory
                 :recurse recurse :exclude exclude :collect #'collect))))))
    processed))

(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).
(defun ensure-source-registry ()
  (if (source-registry-initialized-p)
      (source-registry)
      (initialize-source-registry)))
;;;; -----------------------------------------------------------------
;;;; SBCL hook into REQUIRE
;;;;
#+sbcl
(progn
  (defun module-provide-asdf (name)
    (handler-bind ((style-warning #'muffle-warning))
      (let* ((*verbose-out* (make-broadcast-stream))
             (system (asdf:find-system name nil)))
        (when system
          (asdf:operate 'asdf:load-op name)
          t))))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
  (pushnew 'module-provide-asdf 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*)))

;; this is a release candidate for ASDF 2.0
(pushnew :asdf2 *features*)