3rdparties/bundle.lisp (6978 bytes)
1 (cl:in-package #:cl-user) 2 3 (eval-when (:compile-toplevel :load-toplevel :execute) 4 (require "asdf") 5 (unless (find-package '#:asdf) 6 (error "ASDF could not be required"))) 7 8 (let ((indicator '#:ql-bundle-v1) 9 (searcher-name '#:ql-bundle-searcher) 10 (base (make-pathname :name nil :type nil 11 :defaults #. (or *compile-file-truename* 12 *load-truename*)))) 13 (labels ((file-lines (file) 14 (with-open-file (stream file) 15 (loop for line = (read-line stream nil) 16 while line 17 collect line))) 18 (relative (pathname) 19 (merge-pathnames pathname base)) 20 (pathname-timestamp (pathname) 21 #+clisp 22 (nth-value 2 (ext:probe-pathname pathname)) 23 #-clisp 24 (file-write-date pathname)) 25 (system-table (table pathnames) 26 (dolist (pathname pathnames table) 27 (setf (gethash (pathname-name pathname) table) 28 (relative pathname)))) 29 30 (initialize-bundled-systems-table (table data-source) 31 (system-table table 32 (mapcar (lambda (line) 33 (merge-pathnames line data-source)) 34 (file-lines data-source)))) 35 36 (local-projects-system-pathnames (data-source) 37 (let ((files (directory (merge-pathnames "**/*.asd" 38 data-source)))) 39 (stable-sort (sort files #'string< :key #'namestring) 40 #'< 41 :key (lambda (file) 42 (length (namestring file)))))) 43 (initialize-local-projects-table (table data-source) 44 (system-table table (local-projects-system-pathnames data-source))) 45 46 (make-table (&key data-source init-function) 47 (let ((table (make-hash-table :test 'equalp))) 48 (setf (gethash "/data-source" table) 49 data-source 50 (gethash "/timestamp" table) 51 (pathname-timestamp data-source) 52 (gethash "/init" table) 53 init-function) 54 table)) 55 56 (tcall (table key &rest args) 57 (let ((fun (gethash key table))) 58 (unless (and fun (functionp fun)) 59 (error "Unknown function key ~S" key)) 60 (apply fun args))) 61 (created-timestamp (table) 62 (gethash "/timestamp" table)) 63 (data-source-timestamp (table) 64 (pathname-timestamp (data-source table))) 65 (data-source (table) 66 (gethash "/data-source" table)) 67 68 (stalep (table) 69 ;; FIXME: Handle newly missing data sources? 70 (< (created-timestamp table) 71 (data-source-timestamp table))) 72 (meta-key-p (key) 73 (and (stringp key) 74 (< 0 (length key)) 75 (char= (char key 0) #\/))) 76 (clear (table) 77 ;; Don't clear "/foo" keys 78 (maphash (lambda (key value) 79 (declare (ignore value)) 80 (unless (meta-key-p key) 81 (remhash key table))) 82 table)) 83 (initialize (table) 84 (tcall table "/init" table (data-source table)) 85 (setf (gethash "/timestamp" table) 86 (pathname-timestamp (data-source table))) 87 table) 88 (update (table) 89 (clear table) 90 (initialize table)) 91 (lookup (system-name table) 92 (when (stalep table) 93 (update table)) 94 (values (gethash system-name table))) 95 96 (search-function (system-name) 97 (let ((tables (get searcher-name indicator))) 98 (dolist (table tables) 99 (let* ((result (lookup system-name table)) 100 (probed (and result (probe-file result)))) 101 (when probed 102 (return probed)))))) 103 104 (make-bundled-systems-table () 105 (initialize 106 (make-table :data-source (relative "system-index.txt") 107 :init-function #'initialize-bundled-systems-table))) 108 (make-bundled-local-projects-systems-table () 109 (let ((data-source (relative "bundled-local-projects/system-index.txt"))) 110 (when (probe-file data-source) 111 (initialize 112 (make-table :data-source data-source 113 :init-function #'initialize-bundled-systems-table))))) 114 (make-local-projects-table () 115 (initialize 116 (make-table :data-source (relative "local-projects/") 117 :init-function #'initialize-local-projects-table))) 118 119 (=matching-data-sources (tables) 120 (let ((data-sources (mapcar #'data-source tables))) 121 (lambda (table) 122 (member (data-source table) data-sources 123 :test #'equalp)))) 124 125 (check-for-existing-searcher (searchers) 126 (block done 127 (dolist (searcher searchers) 128 (when (symbolp searcher) 129 (let ((plist (symbol-plist searcher))) 130 (loop for key in plist by #'cddr 131 when 132 (and (symbolp key) (string= key indicator)) 133 do 134 (setf indicator key) 135 (setf searcher-name searcher) 136 (return-from done t))))))) 137 138 (clear-asdf (table) 139 (maphash (lambda (system-name pathname) 140 (declare (ignore pathname)) 141 (asdf:clear-system system-name)) 142 table))) 143 144 (let ((existing (check-for-existing-searcher 145 asdf:*system-definition-search-functions*))) 146 (let* ((local (make-local-projects-table)) 147 (bundled-local-projects 148 (make-bundled-local-projects-systems-table)) 149 (bundled (make-bundled-systems-table)) 150 (new-tables (remove nil (list local 151 bundled-local-projects 152 bundled))) 153 (existing-tables (get searcher-name indicator)) 154 (filter (=matching-data-sources new-tables))) 155 (setf (get searcher-name indicator) 156 (append new-tables (delete-if filter existing-tables))) 157 (map nil #'clear-asdf new-tables)) 158 (unless existing 159 (setf (symbol-function searcher-name) #'search-function) 160 (push searcher-name asdf:*system-definition-search-functions*))) 161 t))