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
|
(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 (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-local-projects-table ()
(initialize
(make-table :data-source (relative "local-projects/")
:init-function #'initialize-local-projects-table)))
(=matching-data-sources (&rest 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* ((bundled (make-bundled-systems-table))
(local (make-local-projects-table))
(existing-tables (get searcher-name indicator))
(filter (=matching-data-sources bundled local)))
(setf (get searcher-name indicator)
(list* local bundled (delete-if filter existing-tables)))
(clear-asdf local)
(clear-asdf bundled))
(unless existing
(setf (symbol-function searcher-name) #'search-function)
(push searcher-name asdf:*system-definition-search-functions*)))
t))
|
