Skip to content
Snippets Groups Projects
asdf.lisp 95.1 KiB
Newer Older
    (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))))
;;;; -----------------------------------------------------------------
;;;; 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))))
  (defun contrib-sysdef-search (system)
      (when (and home (not (string= home "")))
        (let* ((name (coerce-name system))
               (home (truename home))
               (contrib (merge-pathnames
                         (make-pathname :directory `(:relative ,name)
                                        :name name
                                        :type "asd"
                                        :case :local
                                        :version :newest)
                         home)))
          (probe-file contrib)))))
      (when (and home (not (string= home "")))
        (merge-pathnames "site-systems/" (truename home))))
   *central-registry*)
   '(merge-pathnames ".sbcl/systems/"
     (user-homedir-pathname))
   *central-registry*)
  (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
  (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
;;;; -----------------------------------------------------------------
;;;; Source Registry Configuration, by Francois-Rene Rideau
;;;; See README.source-registry and https://bugs.launchpad.net/asdf/+bug/485918
(pushnew 'sysdef-source-registry-search *system-definition-search-functions*)

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

(defun default-registry ()

(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 read-file-forms (file)
  (with-open-file (in file)
    (loop :with eof = (list nil)
     :for form = (read in nil eof)
     :until (eq form eof)
     :collect form)))

(defun validate-source-registry-directive (directive)
  (or
   (destructuring-bind (kw &rest rest) directive
     (case kw
       ((:include :directory :tree)
        (and (length=n-p rest 1)
             (typep (car rest) '(or pathname string))))
       ((:exclude)
        (every #'stringp rest))
       ((:default-registry :inherit-configuration :ignore-inherited-configuration)
        (null rest))))
   (error "Invalid directive ~S~%" directive)))

(defun validate-source-registry-form (form)
  (unless (and (consp form) (eq (car form) :source-registry))
    (error "Error: Form is not a source registry ~S~%" form))
  (loop :with inherit = 0
        :for directive :in (cdr form) :do
        (unless (consp directive)
          (error "invalid directive ~S" directive))
        (when (member (car directive)
                      '(:inherit-configuration :ignore-inherited-configuration))
          (incf inherit))
        (validate-source-registry-directive directive)
        :finally
        (unless (= inherit 1)
          (error "One and only one of :inherit-configuration or :ignore-inherited-configuration is required")))
  form)

(defun validate-source-registry-file (file)
  (let ((forms (read-file-forms file)))
    (unless (length=n-p forms 1)
      (error "Only and only one form allowed for source registry. Got: ~S~%" forms))
    (validate-source-registry-form (car forms))))

(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))
    ((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 collect-asd-subdirectories (directory &key (exclude *default-exclusions*) collect)
  (let* ((files (directory (merge-pathnames #P"**/*.asd" directory)
                       #+sbcl #+sbcl :resolve-symlinks nil
                       #+clisp #+clisp :circle t))
         (dirs (remove-duplicates (mapcar #'pathname-sans-name+type files) :test #'equal)))
     :unless (loop :for x :in exclude
                   :thereis (find x (pathname-directory dir) :test #'equal))
     :do (funcall collect dir))))

(defparameter *default-source-registries*
  '(process-environment-source-registry
    process-user-source-registry
    process-system-source-registry
    process-default-source-registry))

(defun source-registry-under (directory)
  (merge-pathnames "common-lisp/source-registry.conf" directory))
(defun user-source-registry-pathname ()
  (source-registry-under (merge-pathnames ".config/" (user-homedir-pathname))))
(defun system-source-registry-pathname ()
  (source-registry-under "/etc/"))

(defun process-environment-source-registry (&key inherit collect)
  (process-source-registry (getenv "CL_SOURCE_REGISTRY")
                           :inherit inherit :collect collect))
(defun process-user-source-registry (&key inherit collect)
  (process-source-registry (user-source-registry-pathname)
                           :inherit inherit :collect collect))
(defun process-system-source-registry (&key inherit collect)
  (process-source-registry (system-source-registry-pathname)
                           :inherit inherit :collect collect))
(defun process-default-source-registry (&key inherit collect)
  (declare (ignore inherit collect))
  nil)
(defgeneric process-source-registry (spec &key inherit collect))
(defmethod process-source-registry ((pathname pathname) &key
                                    (inherit *default-source-registries*)
                                    collect)
  (if (probe-file pathname)
    (process-source-registry (validate-source-registry-file pathname)
                             :inherit inherit :collect collect)
    (inherit-source-registry inherit :collect collect)))
(defmethod process-source-registry ((string string) &key
                                    (inherit *default-source-registries*)
                                    collect)
  (process-source-registry (parse-source-registry-string string)
                           :inherit inherit :collect collect))
(defmethod process-source-registry ((x null) &key
                                    (inherit *default-source-registries*)
                                    collect)
  (inherit-source-registry inherit :collect collect))

(defun make-collector ()
  (let ((acc ()))
    (values (lambda (x) (push x acc))
            (lambda () (reverse acc)))))

(defmethod process-source-registry ((form cons) &key
                                    (inherit *default-source-registries*)
                                    collect)
  (multiple-value-bind (collect result)
      (if collect
          (values collect (constantly nil))
        (make-collector))
    (let ((*default-exclusions* *default-exclusions*))
      (dolist (directive (cdr (validate-source-registry-form form)))
        (process-source-registry-directive directive :inherit inherit :collect collect)))
    (funcall result)))

(defun inherit-source-registry (inherit &key collect)
  (when inherit
    (funcall (first inherit) :collect collect :inherit (rest inherit))))

(defun process-source-registry-directive (directive &key inherit collect)
  (destructuring-bind (kw &rest rest) directive
    (ecase kw
      ((:include)
       (destructuring-bind (pathname) rest
         (process-source-registry (pathname pathname) :inherit inherit :collect collect)))
      ((:directory)
       (destructuring-bind (pathname) rest
         (funcall collect (ensure-directory-pathname pathname))))
      ((:tree)
       (destructuring-bind (pathname) rest
         (collect-asd-subdirectories pathname :collect collect)))
      ((:exclude)
       (setf *default-exclusions* rest))
      ((:default-registry)
       (default-registry))
      ((:inherit-configuration)
       (inherit-source-registry inherit :collect collect))
      ((:ignore-inherited-configuration)
       nil))))
;; Will read the configuration and initialize all internal variables,
;; and return the new configuration.
(defun initialize-source-registry ()
  (setf (source-registry)
        (inherit-source-registry *default-source-registries*)))
;; 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)))
;;;; -------------------------------------------------------------------------
;;;; 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)))))
;;;; -----------------------------------------------------------------
;;;; Done!
(when *load-verbose*
  (asdf-message ";; ASDF, revision ~a" *asdf-revision*))