bundle-template.lisp

(cl:in-package #:cl-user)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require "asdf")
  (unless (find-package '#:asdf)
    (error "ASDF could not be required")))

(let ((indicator '#:ql-bundle-v1)
      (searcher-name '#:ql-bundle-searcher)
      (base (make-pathname :name nil :type nil
                           :defaults #. (or *compile-file-truename*
                                            *load-truename*))))
  (labels ((file-lines (file)
             (with-open-file (stream file)
               (loop for line = (read-line stream nil)
                     while line
                     collect line)))
           (relative (pathname)
             (merge-pathnames pathname base))
           (pathname-timestamp (pathname)
             #+clisp
             (nth-value 2 (ext:probe-pathname pathname))
             #-clisp
             (file-write-date pathname))
           (system-table (table pathnames)
             (dolist (pathname pathnames table)
               (setf (gethash (pathname-name pathname) table)
                     (relative pathname))))

           (initialize-bundled-systems-table (table data-source)
             (system-table table
                           (mapcar (lambda (line)
                                     (merge-pathnames line data-source))
                                   (file-lines data-source))))

           (local-projects-system-pathnames (data-source)
             (let ((files (directory (merge-pathnames "**/*.asd"
                                                      data-source))))
               (stable-sort (sort files #'string< :key #'namestring)
                            #'<
                            :key (lambda (file)
                                   (length (namestring file))))))
           (initialize-local-projects-table (table data-source)
             (system-table table (local-projects-system-pathnames data-source)))

           (make-table (&key data-source init-function)
             (let ((table (make-hash-table :test 'equalp)))
               (setf (gethash "/data-source" table)
                     data-source
                     (gethash "/timestamp" table)
                     (pathname-timestamp data-source)
                     (gethash "/init" table)
                     init-function)
               table))

           (tcall (table key &rest args)
             (let ((fun (gethash key table)))
               (unless (and fun (functionp fun))
                 (error "Unknown function key ~S" key))
               (apply fun args)))
           (created-timestamp (table)
             (gethash "/timestamp" table))
           (data-source-timestamp (table)
             (pathname-timestamp (data-source table)))
           (data-source (table)
             (gethash "/data-source" table))

           (stalep (table)
             ;; FIXME: Handle newly missing data sources?
             (< (created-timestamp table)
                (data-source-timestamp table)))
           (meta-key-p (key)
             (and (stringp key)
                  (< 0 (length key))
                  (char= (char key 0) #\/)))
           (clear (table)
             ;; Don't clear "/foo" keys
             (maphash (lambda (key value)
                        (declare (ignore value))
                        (unless (meta-key-p key)
                          (remhash key table)))
                      table))
           (initialize (table)
             (tcall table "/init" table (data-source table))
             (setf (gethash "/timestamp" table)
                   (pathname-timestamp (data-source table)))
             table)
           (update (table)
             (clear table)
             (initialize table))
           (lookup (system-name table)
             (when (stalep table)
               (update table))
             (values (gethash system-name table)))

           (search-function (system-name)
             (let ((tables (get searcher-name indicator)))
               (dolist (table tables)
                 (let* ((result (lookup system-name table))
                        (probed (and result (probe-file result))))
                   (when probed
                     (return probed))))))

           (make-bundled-systems-table ()
             (initialize
              (make-table :data-source (relative "system-index.txt")
                          :init-function #'initialize-bundled-systems-table)))
           (make-bundled-local-projects-systems-table ()
             (let ((data-source (relative "bundled-local-projects/system-index.txt")))
               (when (probe-file data-source)
                 (initialize
                  (make-table :data-source data-source
                              :init-function #'initialize-bundled-systems-table)))))
           (make-local-projects-table ()
             (initialize
              (make-table :data-source (relative "local-projects/")
                          :init-function #'initialize-local-projects-table)))

           (=matching-data-sources (tables)
             (let ((data-sources (mapcar #'data-source tables)))
               (lambda (table)
                 (member (data-source table) data-sources
                         :test #'equalp))))

           (check-for-existing-searcher (searchers)
             (block done
               (dolist (searcher searchers)
                 (when (symbolp searcher)
                   (let ((plist (symbol-plist searcher)))
                     (loop for key in plist by #'cddr
                           when
                           (and (symbolp key) (string= key indicator))
                           do
                           (setf indicator key)
                           (setf searcher-name searcher)
                           (return-from done t)))))))

           (clear-asdf (table)
             (maphash (lambda (system-name pathname)
                        (declare (ignore pathname))
                        (asdf:clear-system system-name))
                      table)))

    (let ((existing (check-for-existing-searcher
                     asdf:*system-definition-search-functions*)))
      (let* ((local (make-local-projects-table))
             (bundled-local-projects
              (make-bundled-local-projects-systems-table))
             (bundled (make-bundled-systems-table))
             (new-tables (remove nil (list local
                                           bundled-local-projects
                                           bundled)))
             (existing-tables (get searcher-name indicator))
             (filter (=matching-data-sources new-tables)))
        (setf (get searcher-name indicator)
              (append new-tables (delete-if filter existing-tables)))
        (map nil #'clear-asdf new-tables))
      (unless existing
        (setf (symbol-function searcher-name) #'search-function)
        (push searcher-name asdf:*system-definition-search-functions*)))
    t))