bundle.lisp - clic - Clic is an command line interactive client for gopher writ… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
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-s… | |
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-ta… | |
108 (make-bundled-local-projects-systems-table () | |
109 (let ((data-source (relative "bundled-local-projects/system… | |
110 (when (probe-file data-source) | |
111 (initialize | |
112 (make-table :data-source data-source | |
113 :init-function #'initialize-bundled-system… | |
114 (make-local-projects-table () | |
115 (initialize | |
116 (make-table :data-source (relative "local-projects/") | |
117 :init-function #'initialize-local-projects-tab… | |
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)) |