Skip to content
Snippets Groups Projects
Commit e8a3285f authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Fix more of the bugs. Scanning of subdiretories very slow on SBCL.

parent 79502b1c
No related branches found
No related tags found
No related merge requests found
......@@ -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.
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment