From e8a3285fea1e2aa593ccee23e6976a323ec4c380 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Fri, 15 Jan 2010 05:16:13 -0500
Subject: [PATCH] Fix more of the bugs. Scanning of subdiretories very slow on
 SBCL.

---
 asdf.lisp | 268 ++++++++++++++++++++++--------------------------------
 1 file changed, 110 insertions(+), 158 deletions(-)

diff --git a/asdf.lisp b/asdf.lisp
index 5e080bf4..af7e7b7d 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -139,6 +139,7 @@
            #:*enable-asdf-binary-locations*
            #:implementation-specific-directory-name)
   (:intern #:coerce-name
+           #:getenv
            #:system-registered-p
            #:asdf-message
            #:resolve-symlinks
@@ -149,6 +150,7 @@
   (:use #:common-lisp #:asdf)
   (:import-from #:asdf
                 #:coerce-name
+                #:getenv
                 #:system-registered-p
                 #:asdf-message
                 #:resolve-symlinks
@@ -406,6 +408,25 @@ and NIL NAME and TYPE components"
   #-allegro (truename path)
   #+allegro (excl:pathname-resolve-symbolic-links path))
 
+(defun getenv (x)
+  #+sbcl
+  (sb-ext:posix-getenv x)
+  #+clozure
+  (ccl::getenv x)
+  #+clisp
+  (ext:getenv x)
+  #+cmu
+  (cdr (assoc (intern x :keyword) ext:*environment-list*))
+  #+lispworks
+  (lispworks:environment-xiable x)
+  #+allegro
+  (sys:getenv x)
+  #+gcl
+  (system:getenv x)
+  #+ecl
+  (si:getenv x))
+
+
 ;;;; -------------------------------------------------------------------------
 ;;;; Classes, Conditions
 
@@ -629,8 +650,7 @@ called with an object of type asdf:system."
 ;;; convention that functions in this list are prefixed SYSDEF-
 
 (defvar *system-definition-search-functions*
-  '(sysdef-central-registry-search
-    sysdef-source-registry-search))
+  '(sysdef-central-registry-search))
 
 (defun system-definition-pathname (system)
   (let ((system-name (coerce-name system)))
@@ -732,60 +752,6 @@ to `~a` which is not a directory.~@:>"
                           (list new)
                           (subseq *central-registry* (1+ position))))))))))
 
-(defun sysdef-source-registry-search (system)
-  (let ((name (coerce-name system))
-        (to-remove nil)
-        (to-replace nil))
-    (block nil
-      (unwind-protect
-           (dolist (dir (source-registry))
-             (let ((defaults (eval dir)))
-               (when defaults
-                 (cond ((directory-pathname-p defaults)
-                        (let ((file (and defaults
-                                         (make-pathname
-                                          :defaults defaults :version :newest
-                                          :name name :type "asd" :case :local)))
-                               #+(and (or win32 windows) (not :clisp))
-                               (shortcut (make-pathname
-                                          :defaults defaults :version :newest
-                                          :name name :type "asd.lnk" :case :local)))
-                          (if (and file (probe-file file))
-                              (return file))
-                          #+(and (or win32 windows) (not :clisp))
-                          (when (probe-file shortcut)
-                            (let ((target (parse-windows-shortcut shortcut)))
-                              (when target
-                                (return (pathname target)))))))
-                       (t
-                        (restart-case
-                            (let* ((*print-circle* nil)
-                                   (message
-                                    (format nil
-                                            "~@<While searching for system `~a`: `~a` evaluated ~
-to `~a` which is not a directory.~@:>"
-                                            system dir defaults)))
-                              (error message))
-                          (remove-entry-from-registry ()
-                            :report "Remove entry from (source-registry) and continue"
-                            (push dir to-remove))
-                          (coerce-entry-to-directory ()
-                            :report (lambda (s)
-                                      (format s "Coerce entry to ~a, replace ~a and continue."
-                                              (ensure-directory-pathname defaults) dir))
-                            (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
-        ;; cleanup
-        (dolist (dir to-remove)
-          (setf (central-registry) (remove dir (source-registry))))
-        (dolist (pair to-replace)
-          (let* ((current (car pair))
-                 (new (cdr pair))
-                 (position (position current (source-registry))))
-            (setf (source-registry)
-                  (append (subseq (source-registry) 0 position)
-                          (list new)
-                          (subseq (source-registry) (1+ position))))))))))
-
 (defun make-temporary-package ()
   (flet ((try (counter)
            (ignore-errors
@@ -2097,23 +2063,7 @@ applied by the plain `*source-to-target-mappings*`."
 ;;;; for invalidating registry entries, etc.
 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
 
-(defun get-env-var (x)
-  #+sbcl
-  (sb-ext:posix-getenv x)
-  #+clozure
-  (ccl::getenv x)
-  #+clisp
-  (ext:getenv x)
-  #+cmu
-  (cdr (assoc (intern x :keyword) ext:*environment-list*))
-  #+lispworks
-  (lispworks:environment-xiable x)
-  #+allegro
-  (sys:getenv x)
-  #+gcl
-  (system:getenv x)
-  #+ecl
-  (si:getenv x))
+(pushnew 'sysdef-source-registry-search *system-definition-search-functions*)
 
 ;; Using ack 1.2 exclusions
 (defvar *default-exclusions*
@@ -2122,37 +2072,53 @@ applied by the plain `*source-to-target-mappings*`."
     "_sgbak" "autom4te.cache" "cover_db" "_build"))
 
 (defun default-registry ()
-  (let ((paths #+(and asdf sbcl)
-               (list
-                (let ((home (sb-ext:posix-getenv "SBCL_HOME")))
-                  (when (and home (not (string= home "")))
-                    (merge-pathnames "site-systems/" (truename home))))
-                (merge-pathnames ".sbcl/systems/"
-                                 (user-homedir-pathname)))
-               #+(and asdf clisp)
-               (list
-                (merge-pathnames ".clc/systems/"
-                                 (user-homedir-pathname))
-                *default-pathname-defaults*
-                #P"/usr/share/common-lisp/systems/")
-               ;; asdf:*central-registry*
-               #+xcvb
-               xcvb:*search-path*))
-    (mapcar #'namestring paths)))
-
-(defvar *source-registry* '())
-;; (defvar *source-registry* (default-registry))
+  ())
+
+(defvar *source-registry* ())
 
 (defun source-registry ()
-  *source-registry*)
+  (car *source-registry*))
 
 (defun (setf source-registry) (x)
-  (setf *source-registry* x))
+  (setf *source-registry* (list x)))
 
 (defun source-registry-initialized-p ()
-  (not (null (source-registry))))
+  (and *source-registry* t))
+
+(defun clear-source-registry ()
+  "Undoes any initialization of the source registry.
+You might want to call that before you dump an image that would be resumed
+with a different configuration, so the configuration would be re-read then."
+  ;; TODO: in the future, have a hook that clients will use to clear any cache
+  ;; that depends on this configuration.
+  (setf *source-registry* '())
+  (values))
 
-;; from xcvb:search-path.lisp
+(defun sysdef-source-registry-search (system)
+  (ensure-source-registry)
+  (let ((name (coerce-name system)))
+    (block nil
+      (dolist (dir (source-registry))
+        (let ((defaults (eval dir)))
+          (when defaults
+            (cond ((directory-pathname-p defaults)
+                   (let ((file (and defaults
+                                    (make-pathname
+                                     :defaults defaults :version :newest
+                                     :name name :type "asd" :case :local)))
+                         #+(and (or win32 windows) (not :clisp))
+                         (shortcut (make-pathname
+                                    :defaults defaults :version :newest
+                                    :name name :type "asd.lnk" :case :local)))
+                     (when (and file (probe-file file))
+                       (return file))
+                     #+(and (or win32 windows) (not :clisp))
+                     (when (probe-file shortcut)
+                       (let ((target (parse-windows-shortcut shortcut)))
+                         (when target
+                           (return (pathname target))))))))))))))
+
+;; from xcvb/search-path
 (defun expand-search-path-string (string &optional (previous-path (source-registry)))
   (cond
     ((or (null string) (equal string ""))
@@ -2192,23 +2158,6 @@ form."
                           :defaults pathname))
           (t pathname))))
 
-(defun directory-exists-p (pathspec)
-  "Checks whether the file named by the pathname designator PATHSPEC
-exists and if it is a directory.  Returns its truename if this is the
-case, NIL otherwise.  The truename is returned in directory form as if
-by PATHNAME-AS-DIRECTORY."
-  #+:allegro
-  (and (excl:probe-directory pathspec)
-       (pathname-as-directory (truename pathspec)))
-  #+:lispworks
-  (and (lw:file-directory-p pathspec)
-       (pathname-as-directory (truename pathspec)))
-  #-(or :allegro :lispworks)
-  (let ((result (file-exists-p pathspec)))
-    (and result
-         (directory-pathname-p result)
-         result)))
-
 (defun file-exists-p (pathname)
   #+(or sbcl lispworks openmcl)
   (probe-file pathname)
@@ -2228,6 +2177,23 @@ by PATHNAME-AS-DIRECTORY."
   #-(or sbcl cmu lispworks openmcl allegro clisp)
   (error "list-directory not implemented"))
 
+(defun directory-exists-p (pathspec)
+  "Checks whether the file named by the pathname designator PATHSPEC
+exists and if it is a directory.  Returns its truename if this is the
+case, NIL otherwise.  The truename is returned in directory form as if
+by PATHNAME-AS-DIRECTORY."
+  #+:allegro
+  (and (excl:probe-directory pathspec)
+       (pathname-as-directory (truename pathspec)))
+  #+:lispworks
+  (and (lw:file-directory-p pathspec)
+       (pathname-as-directory (truename pathspec)))
+  #-(or :allegro :lispworks)
+  (let ((result (file-exists-p pathspec)))
+    (and result
+         (directory-pathname-p result)
+         result)))
+
 (defun every-string-p (x)
   (every #'stringp x))
 
@@ -2235,13 +2201,13 @@ by PATHNAME-AS-DIRECTORY."
 
 (defmethod extract-registry-paths ((type (eql 'files)))
   (let ((base "source-registry.conf")
-	(dirs (list (pathname "/etc/common-lisp/")
-		    (merge-pathnames ".config/common-lisp/" (user-homedir-pathname)))))
+        (dirs (list (merge-pathnames ".config/common-lisp/" (user-homedir-pathname))
+                    (pathname "/etc/common-lisp/"))))
     (loop :for dir :in dirs :collect
-	  (merge-pathnames base dir))))
+          (merge-pathnames base dir))))
 
 (defmethod extract-registry-paths ((type (eql 'environment)))
-  (let ((source-path (get-env-var "CL_SOURCE_REGISTRY")))
+  (let ((source-path (getenv "CL_SOURCE_REGISTRY")))
     (when source-path
       (expand-search-path source-path))))
 
@@ -2266,7 +2232,7 @@ by PATHNAME-AS-DIRECTORY."
 (defun recurse-directory (directory &optional (exclusions *default-exclusions*) undetect)
   (declare (ignorable exclusions))
   (let* ((f (directory (merge-pathnames
-                        (if undetect 
+                        (if undetect
                           #P"**/*.*"
                           (progn
                             #+(or asdf sbcl) #P"**/*.asd"
@@ -2331,7 +2297,6 @@ by PATHNAME-AS-DIRECTORY."
                 :do (validate-directive dir))))
           (t (error "Error: Unhandled condition")))))
 
-
 (defun acquire-paths (path &optional recurse)
   (when (directory-exists-p path)
     (let ((p (ensure-directory-trailing-slash path)))
@@ -2339,15 +2304,6 @@ by PATHNAME-AS-DIRECTORY."
           (recurse-directory p)
         (list p)))))
 
-;; checks an initial variable to see whether the state is initialized
-;; or cleared. In the former case, return current configuration; in
-;; the latter, initialize.  ASDF will call this function at the start
-;; of (asdf:find-system).
-(defun ensure-source-registry ()
-  (if (source-registry-initialized-p)
-      (source-registry)
-      (initialize-source-registry)))
-
 ;; TODO: remove duplicates, but won't it be expensive to have duplicates
 ;; removed everytime a new item is to be added?
 (defun add-path-to-source-registry (path &optional recurse)
@@ -2385,22 +2341,6 @@ by PATHNAME-AS-DIRECTORY."
          directive)
         (t (error "Error: Unhandled condition."))))
 
-(defun process-source-registry-path (path)
-  (validate-file path)
-  (multiple-value-bind (registry count)
-      (read-file path)
-    (destructuring-bind (((top &rest rest)) c)
-        (list registry count)
-      (declare (ignore c)
-               (ignorable top))
-      (loop
-       :for reg :in rest
-       :nconc (process-source-registry reg)))))
-
-(defun process-source-registry-paths (paths)
-  (loop :for path :in paths
-        :nconc (process-source-registry-path path)))
-
 ;; If X is a CONS, parse it as a SEXP in the configuration DSL, and
 ;; extend or override inheritted configuration.  If X is a STRING,
 ;; first parse it into a SEXP with READ (Alternate proposal: parse
@@ -2433,6 +2373,23 @@ by PATHNAME-AS-DIRECTORY."
           ((:ignore-inherited-configuration)
            nil))))))
 
+(defun process-source-registry-path (path)
+  (when (probe-file path)
+    (validate-file path)
+    (multiple-value-bind (registry count)
+        (read-file path)
+      (destructuring-bind (((top &rest rest)) c)
+          (list registry count)
+        (declare (ignore c)
+                 (ignorable top))
+        (loop
+          :for reg :in rest
+          :nconc (process-source-registry reg))))))
+
+(defun process-source-registry-paths (paths)
+  (loop :for path :in paths
+        :nconc (process-source-registry-path path)))
+
 ;; Will read the configuration and initialize all internal variables,
 ;; and return the new configuration.
 (defun initialize-source-registry ()
@@ -2443,20 +2400,15 @@ by PATHNAME-AS-DIRECTORY."
     (when registry
       (setf (source-registry) (remove-duplicates registry :test #'equal)))
     (source-registry)))
-  
-;; Undoes any initialization. You might want to call that before you
-;; dump an image that would be resumed with a different configuration,
-;; and return an empty configuration.  Also will have a hook that
-;; allows clients will use to clear any cache that depends on this
-;; configuration.
-(defun clear-source-registry ()
-  (setf (source-registry) '())
 
-  ;; Should this module care about these variables?
-  ;; (setf asdf::*central-registry* nil)
-  ;; (setf xcvb::*search-path* nil)
-
-  (values (source-registry)))
+;; checks an initial variable to see whether the state is initialized
+;; or cleared. In the former case, return current configuration; in
+;; the latter, initialize.  ASDF will call this function at the start
+;; of (asdf:find-system).
+(defun ensure-source-registry ()
+  (if (source-registry-initialized-p)
+      (source-registry)
+      (initialize-source-registry)))
 
 ;;;; -------------------------------------------------------------------------
 ;;;; Cleanups after hot-upgrade.
-- 
GitLab