Fix more of the bugs. Scanning of subdiretories very slow on SBCL. (e8a3285f) · Commits · Hugo Ishimaru / asdf

asdf.lisp

+110 −158

Original line number	Diff line number	Diff line
		@@ -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))

		;; from xcvb:search-path.lisp
		(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))

		(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))))

		(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))))

		@@ -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 ()
		@@ -2444,19 +2401,14 @@ by PATHNAME-AS-DIRECTORY."
		(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.