Skip to content

Commit 9cac183

Browse files
xachxach
committed
More bundling.
1 parent 5b5657c commit 9cac183

File tree

4 files changed

+159
-5
lines changed

4 files changed

+159
-5
lines changed

‎quicklisp/bundle-template.lisp

Lines changed: 129 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,129 @@
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 loaded")))
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 (file-lines data-source)))
32+
33+
(local-projects-system-pathnames (data-source)
34+
(let ((files (directory (merge-pathnames "**/*.asd"
35+
data-source))))
36+
(stable-sort (sort files #'string< :key #'namestring)
37+
#'<
38+
:key (lambda (file)
39+
(length (namestring file))))))
40+
(initialize-local-projects-table (table data-source)
41+
(system-table table (local-projects-system-pathnames data-source)))
42+
43+
(make-table (&key data-source init-function)
44+
(let ((table (make-hash-table :test 'equalp)))
45+
(setf (gethash "/data-source" table)
46+
data-source
47+
(gethash "/timestamp" table)
48+
(pathname-timestamp data-source)
49+
(gethash "/init" table)
50+
init-function)
51+
table))
52+
53+
(tcall (table key &rest args)
54+
(let ((fun (gethash key table)))
55+
(unless (and fun (functionp fun))
56+
(error "Unknown function key ~S" key))
57+
(apply fun args)))
58+
(created-timestamp (table)
59+
(gethash "/timestamp" table))
60+
(data-source-timestamp (table)
61+
(pathname-timestamp (data-source table)))
62+
(data-source (table)
63+
(gethash "/data-source" table))
64+
65+
(stalep (table)
66+
;; FIXME: Handle newly missing data sources?
67+
(< (created-timestamp table)
68+
(data-source-timestamp table)))
69+
(meta-key-p (key)
70+
(and (stringp key)
71+
(< 0 (length key))
72+
(char= (char key 0) #\/)))
73+
(clear (table)
74+
;; Don't clear "/foo" keys
75+
(maphash (lambda (key value)
76+
(declare (ignore value))
77+
(unless (meta-key-p key)
78+
(remhash key table)))
79+
table))
80+
(initialize (table)
81+
(tcall table "/init" table (data-source table))
82+
(setf (gethash "/timestamp" table)
83+
(pathname-timestamp (data-source table)))
84+
table)
85+
(update (table)
86+
(clear table)
87+
(initialize table))
88+
(lookup (system-name table)
89+
(when (stalep table)
90+
(update table))
91+
(values (gethash system-name table)))
92+
93+
(search-function (system-name)
94+
(let ((tables (get searcher-name indicator)))
95+
(dolist (table tables)
96+
(let* ((result (lookup system-name table))
97+
(probed (and result (probe-file result))))
98+
(when probed
99+
(return probed))))))
100+
101+
(make-bundled-systems-table ()
102+
(initialize
103+
(make-table :data-source (relative "system-index.txt")
104+
:init-function #'initialize-bundled-systems-table)))
105+
(make-local-projects-table ()
106+
(initialize
107+
(make-table :data-source (relative "local-projects/")
108+
:init-function #'initialize-local-projects-table)))
109+
110+
(check-for-existing-searcher (searchers)
111+
(block done
112+
(dolist (searcher searchers)
113+
(when (symbolp searcher)
114+
(let ((plist (symbol-plist searcher)))
115+
(loop for key in plist by #'cddr
116+
when
117+
(and (symbolp key) (string= key indicator))
118+
do
119+
(setf indicator key)
120+
(setf searcher-name searcher)
121+
(return-from done t))))))))
122+
(let ((existing (check-for-existing-searcher
123+
asdf:*system-definition-search-functions*)))
124+
(push (make-bundled-systems-table) (get searcher-name indicator))
125+
(push (make-local-projects-table) (get searcher-name indicator))
126+
(unless existing
127+
(setf (symbol-function searcher-name) #'search-function)
128+
(push searcher-name asdf:*system-definition-search-functions*)))
129+
t))

‎quicklisp/bundle.lisp

Lines changed: 20 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -156,16 +156,34 @@
156156
(format stream "~A/~A~%" prefix system-file)))))
157157

158158
(defmethod write-loader-script ((bundle bundle) stream)
159-
(write-line ";;;; TBD" stream))
159+
(let ((template-lines
160+
(load-time-value
161+
(with-open-file (stream #. (merge-pathnames "bundle-template"
162+
(or *compile-file-truename*
163+
*load-truename*)))
164+
(loop for line = (read-line stream nil)
165+
while line collect line)))))
166+
(dolist (line template-lines)
167+
(write-line line stream))))
160168

161169
(defmethod write-bundle ((bundle bundle) target)
162170
(unpack-releases bundle target)
163171
(let ((index-file (merge-pathnames "system-index.txt" target))
164-
(loader-file (merge-pathnames "bundle-loader.lisp" target)))
172+
(loader-file (merge-pathnames "bundle-loader.lisp" target))
173+
(local-projects (merge-pathnames "local-projects/" target)))
174+
(ensure-directories-exist local-projects)
165175
(with-open-file (stream index-file :direction :output
166176
:if-exists :supersede)
167177
(write-system-index bundle stream))
168178
(with-open-file (stream loader-file :direction :output
169179
:if-exists :supersede)
170180
(write-loader-script bundle stream)))
171181
bundle)
182+
183+
184+
(defun ql:bundle-systems (system-names &key to)
185+
(unless to
186+
(error "TO argument must be provided"))
187+
(let ((bundle (make-instance 'bundle)))
188+
(add-systems-recursively system-names bundle)
189+
(write-bundle bundle to)))

‎quicklisp/package.lisp

Lines changed: 8 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -258,7 +258,12 @@
258258
"A package for supporting the QL:BUNDLE-SYSTEMS function.")
259259
(:use #:cl #:ql-dist)
260260
(:shadow #:find-system
261-
#:find-release))
261+
#:find-release)
262+
(:export #:bundle
263+
#:ensure-system
264+
#:ensure-release
265+
#:write-bundle
266+
#:add-systems-recursively))
262267

263268
(defpackage #:quicklisp-client
264269
(:documentation
@@ -315,6 +320,7 @@
315320
#:*local-project-directories*
316321
#:list-local-projects
317322
#:list-local-systems
318-
#:who-depends-on))
323+
#:who-depends-on
324+
#:bundle-systems))
319325

320326
(in-package #:quicklisp-client)

‎quicklisp/quicklisp.asd

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -32,4 +32,5 @@
3232
(:file "client-update")
3333
(:file "dist-update")
3434
(:file "misc")
35-
(:file "local-projects")))
35+
(:file "local-projects")
36+
(:file "bundle")))

0 commit comments

Comments
 (0)