bundle.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
bundle.lisp (6978B)
---
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))