Use an ASDF system-search-function hook instead of catching ASDF errors.

Author: attila-lendvai

quicklisp/client.lisp

@@ -34,7 +34,11 @@
         (setf systems (list systems)))
       (dolist (thing systems systems)
         (flet ((ql ()
-                 (autoload-system-and-dependencies thing :prompt prompt)))
+                 (let ((asdf:*system-definition-search-functions*
+                        (append asdf:*system-definition-search-functions*
+                                '(ql::system-definition-searcher/auto-download)))
+                       (*quickload-prompt* prompt))
+                   (asdf:load-system thing))))
           (if verbose
               (ql)
               (call-with-quiet-compilation #'ql)))))))

quicklisp/setup.lisp

@@ -61,6 +61,37 @@
   system given to load is not available via ASDF or a Quicklisp
   dist."))
 
+;; Internal variable to keep track of which systems we have tried to load already.
+(defvar *searching/seen-asdf-systems*)
+
+(defun system-definition-searcher/auto-download (name)
+  "An ASDF system definition search function. It's used internally to hook into ASDF:FIND-SYSTEM to automatically download systems."
+  (flet
+      ((body ()
+         (unless (gethash name *searching/seen-asdf-systems*)
+           (setf (gethash name *searching/seen-asdf-systems*) t)
+           (flet ((try-finding-it ()
+                    (let ((system-file (find-asdf-system-file name)))
+                      (when (and system-file
+                                 (string= (pathname-name system-file) name))
+                        system-file))))
+             (or (try-finding-it)
+                 (progn
+                   (let ((strategy (compute-load-strategy name)))
+                     (show-load-strategy strategy)
+                     ;; TODO FIXME *quickload-prompt* is forward referenced
+                     (when (or (not quicklisp-client::*quickload-prompt*)
+                               (press-enter-to-continue))
+                       (apply-load-strategy strategy)))
+                   (try-finding-it)))))))
+    (if (boundp '*searching/seen-asdf-systems*)
+        ;; we are getting nested
+        (body)
+        ;; only do these once
+        (with-simple-restart (abort "Give up on loading ~S" name)
+          (let ((*searching/seen-asdf-systems* (make-hash-table :test 'equalp)))
+            (body))))))
+
 (defun compute-load-strategy (name)
   (setf name (string-downcase name))
   (let ((asdf-systems '())
@@ -160,42 +191,6 @@
      (format t "~&; Loading ~S~%" (name strategy))
      (asdf:oos 'asdf:load-op (name strategy) :verbose nil))))
 
-(defun autoload-system-and-dependencies (name &key prompt)
-  "Try to load the system named by NAME, automatically loading any
-Quicklisp-provided systems first, and catching ASDF missing
-dependencies too if possible."
-  (setf name (string-downcase name))
-  (with-simple-restart (abort "Give up on ~S" name)
-    (let ((strategy (compute-load-strategy name))
-          (tried-so-far (make-hash-table :test 'equalp)))
-      (show-load-strategy strategy)
-      (when (or (not prompt)
-                (press-enter-to-continue))
-        (tagbody
-         retry
-         (handler-case (apply-load-strategy strategy)
-           (asdf:missing-dependency-of-version (c)
-             ;; Nothing Quicklisp can do to recover from this, so just
-             ;; resignal
-             (error c))
-           (asdf:missing-dependency (c)
-             (let ((parent (asdf::missing-required-by c))
-                   (missing (asdf::missing-requires c)))
-               (typecase parent
-                 (asdf:system
-                  (if (gethash missing tried-so-far)
-                     (error "Dependency looping -- already tried to load ~
-                                 ~A" missing)
-                     (setf (gethash missing tried-so-far) missing))
-                  (autoload-system-and-dependencies missing
-                                                   :prompt prompt)
-                  (go retry))
-                 (t
-                  ;; Error isn't from a system dependency, so there's
-                  ;; nothing to autoload
-                  (error c)))))))))
-    name))
-
 (defvar *initial-dist-url*
   "http://beta.quicklisp.org/dist/quicklisp.txt")