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