1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
|
(cl:in-package #:cl-user)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require "asdf")
(unless (find-package '#:asdf)
(error "ASDF could not be required")))
; Prevent the bundle form from reloading.
; See acl2/acl2 issue 1508 for details.
(defvar *already-loaded-bundle?* nil)
(if *already-loaded-bundle?*
t
(prog1
;; The original form, before the once-only wrapper.
(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))
(setq *already-loaded-bundle?* t)))
|
