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
......@@ -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.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment