|
61 | 61 | system given to load is not available via ASDF or a Quicklisp
|
62 | 62 | dist."))
|
63 | 63 |
|
| 64 | +;; Internal variable to keep track of which systems we have tried to load already. |
| 65 | +(defvar *searching/seen-asdf-systems*) |
| 66 | + |
| 67 | +(defun system-definition-searcher/auto-download (name) |
| 68 | + "An ASDF system definition search function. It's used internally to hook into ASDF:FIND-SYSTEM to automatically download systems." |
| 69 | + (flet |
| 70 | + ((body () |
| 71 | + (unless (gethash name *searching/seen-asdf-systems*) |
| 72 | + (setf (gethash name *searching/seen-asdf-systems*) t) |
| 73 | + (flet ((try-finding-it () |
| 74 | + (let ((system-file (find-asdf-system-file name))) |
| 75 | + (when (and system-file |
| 76 | + (string= (pathname-name system-file) name)) |
| 77 | + system-file)))) |
| 78 | + (or (try-finding-it) |
| 79 | + (progn |
| 80 | + (let ((strategy (compute-load-strategy name))) |
| 81 | + (show-load-strategy strategy) |
| 82 | + ;; TODO FIXME *quickload-prompt* is forward referenced |
| 83 | + (when (or (not quicklisp-client::*quickload-prompt*) |
| 84 | + (press-enter-to-continue)) |
| 85 | + (apply-load-strategy strategy))) |
| 86 | + (try-finding-it))))))) |
| 87 | + (if (boundp '*searching/seen-asdf-systems*) |
| 88 | + ;; we are getting nested |
| 89 | + (body) |
| 90 | + ;; only do these once |
| 91 | + (with-simple-restart (abort "Give up on loading ~S" name) |
| 92 | + (let ((*searching/seen-asdf-systems* (make-hash-table :test 'equalp))) |
| 93 | + (body)))))) |
| 94 | + |
64 | 95 | (defun compute-load-strategy (name)
|
65 | 96 | (setf name (string-downcase name))
|
66 | 97 | (let ((asdf-systems '())
|
|
160 | 191 | (format t "~&; Loading ~S~%" (name strategy))
|
161 | 192 | (asdf:oos 'asdf:load-op (name strategy) :verbose nil))))
|
162 | 193 |
|
163 |
| -(defun autoload-system-and-dependencies (name &key prompt) |
164 |
| - "Try to load the system named by NAME, automatically loading any |
165 |
| -Quicklisp-provided systems first, and catching ASDF missing |
166 |
| -dependencies too if possible." |
167 |
| - (setf name (string-downcase name)) |
168 |
| - (with-simple-restart (abort "Give up on ~S" name) |
169 |
| - (let ((strategy (compute-load-strategy name)) |
170 |
| - (tried-so-far (make-hash-table :test 'equalp))) |
171 |
| - (show-load-strategy strategy) |
172 |
| - (when (or (not prompt) |
173 |
| - (press-enter-to-continue)) |
174 |
| - (tagbody |
175 |
| - retry |
176 |
| - (handler-case (apply-load-strategy strategy) |
177 |
| - (asdf:missing-dependency-of-version (c) |
178 |
| - ;; Nothing Quicklisp can do to recover from this, so just |
179 |
| - ;; resignal |
180 |
| - (error c)) |
181 |
| - (asdf:missing-dependency (c) |
182 |
| - (let ((parent (asdf::missing-required-by c)) |
183 |
| - (missing (asdf::missing-requires c))) |
184 |
| - (typecase parent |
185 |
| - (asdf:system |
186 |
| - (if (gethash missing tried-so-far) |
187 |
| - (error "Dependency looping -- already tried to load ~ |
188 |
| - ~A" missing) |
189 |
| - (setf (gethash missing tried-so-far) missing)) |
190 |
| - (autoload-system-and-dependencies missing |
191 |
| - :prompt prompt) |
192 |
| - (go retry)) |
193 |
| - (t |
194 |
| - ;; Error isn't from a system dependency, so there's |
195 |
| - ;; nothing to autoload |
196 |
| - (error c))))))))) |
197 |
| - name)) |
198 |
| - |
199 | 194 | (defvar *initial-dist-url*
|
200 | 195 | "http://beta.quicklisp.org/dist/quicklisp.txt")
|
201 | 196 |
|
|
0 commit comments