diff --git a/asdf.lisp b/asdf.lisp index f37359c8b36956fc73b7401c6a88b24f56ccc1d2..ca4fd55390207052adf72897582ccab67858c55d 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -629,7 +629,8 @@ 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-central-registry-search + sysdef-source-registry-search)) (defun system-definition-pathname (system) (let ((system-name (coerce-name system))) @@ -731,6 +732,60 @@ 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 @@ -2042,6 +2097,382 @@ 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)) + +;; Using ack 1.2 exclusions +(defvar *default-exclusions* + '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst" + ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" + "_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)) + +(defun source-registry () + *source-registry*) + +(defun (setf source-registry) (x) + (setf *source-registry* x)) + +(defun source-registry-initialized-p () + (not (null (source-registry)))) + +;; from xcvb:search-path.lisp +(defun expand-search-path-string (string &optional (previous-path (source-registry))) + (cond + ((or (null string) (equal string "")) + previous-path) + ((stringp string) + (loop + :with path = () + :with start = 0 + :with end = (length string) + :for i = (or (position #\: string :start start) end) :do + (let ((s (subseq string start i))) + (cond + ((equal "" s) ; empty element + nil) + ((equal "!" s) ; previous path + (setf path (append (reverse previous-path) path))) + (t + (push s path)))) + (setf start (1+ i)) + (when (>= start end) (return (nreverse path))))))) + +(defun expand-search-path (path) + (mapcar #'pathname (expand-search-path-string path))) + +;; from cl-fad:fad.lisp +(defun component-present-p (value) + "Helper function for DIRECTORY-PATHNAME-P which checks whether VALUE +is neither NIL nor the keyword :UNSPECIFIC." + (and value (not (eql value :unspecific)))) + +(defun directory-pathname-p (pathspec) + "Returns NIL if PATHSPEC \(a pathname designator) does not designate +a directory, PATHSPEC otherwise. It is irrelevant whether file or +directory designated by PATHSPEC does actually exist." + (and + (not (component-present-p (pathname-name pathspec))) + (not (component-present-p (pathname-type pathspec))) + pathspec)) + +(defun pathname-as-directory (pathspec) + "Converts the non-wild pathname designator PATHSPEC to directory +form." + (let ((pathname (pathname pathspec))) + (when (wild-pathname-p pathname) + (error "Can't reliably convert wild pathnames.")) + (cond ((not (directory-pathname-p pathspec)) + (make-pathname :directory (append (or (pathname-directory pathname) + (list :relative)) + (list (file-namestring pathname))) + :name nil + :type nil + :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) + + #+(or allegro cmu) + (or (probe-file (pathname-as-directory pathname)) + (probe-file pathname)) + + #+clisp + (or (ignore-errors + (probe-file (pathname-as-file pathname))) + (ignore-errors + (let ((directory-form (pathname-as-directory pathname))) + (when (ext:probe-directory directory-form) + directory-form)))) + + #-(or sbcl cmu lispworks openmcl allegro clisp) + (error "list-directory not implemented")) + +(defun every-string-p (x) + (every #'stringp x)) + +(defgeneric extract-registry-paths (type) (:documentation "")) + +(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))))) + (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"))) + (when source-path + (expand-search-path source-path)))) + +(defmethod extract-registry-paths ((type (eql 'command-line))) + nil) + +(defun directive-validator (directive) + (ecase (first directive) + ((:include) #'file-exists-p) + ((:directory :tree) #'directory-exists-p) + ((:exclude) #'every-string-p) + ((:default-registry + :accept-inherited-configuration + :ignore-inherited-configuration) nil))) + +(defun ensure-directory-trailing-slash (directory) + (let ((dir (if (stringp directory) directory (namestring directory)))) + (if (char= #\/ (aref dir (- (length dir) 1))) + dir + (concatenate 'string dir "/")))) + +(defun recurse-directory (directory &optional (exclusions *default-exclusions*) undetect) + (declare (ignorable exclusions)) + (let* ((f (directory (merge-pathnames + (if undetect + #P"**/*.*" + (progn + #+(or asdf sbcl) #P"**/*.asd" + #+xcvb #P"**/*.xcvb")) + directory))) + (dirs (remove-duplicates (mapcar #'pathname-directory f) :test #'equal))) + (loop + :for dir :in dirs + :for d = (namestring (make-pathname :directory dir)) + :unless (loop :for exclusion :in exclusions :when (search exclusion d) :return t) + :collect d))) + +(defun read-file (file) + (with-open-file (in file) + (loop :with eof = (list nil) + :for form = (read in nil eof) + :and form-count :from 0 + :until (eq form eof) + :collect form :into forms + :finally (return (values forms form-count))))) + +;; (define-condition malformed-init-file-error (error)) + +(defun validate-directive (directive) + (let ((fn (directive-validator directive))) + (destructuring-bind (type &rest rest) + directive + (if (and (keywordp type) + (not (null rest))) + (loop :for dir :in rest + :when (null (funcall fn dir)) + :do (error "~A: Invalid value for directive ~S~%" dir (first directive))))))) + +(defun validate-file (file) + (multiple-value-bind (registry count) + (read-file file) + (cond ((> count 1) + (error "~A:~%Exceeds maximum allowable expression: 1" file)) + ((< (length (first registry)) 2) + (error "Error: Invalid top-level registry~%")) + ((= count 1) + (destructuring-bind (((top &rest rest)) c) + (list registry count) + (declare (ignore c)) + (when (not (eql top :source-registry)) + (error "~A: ~A:~%Invalid top-level directive~%" file top)) + (let ((accept-present (find :accept-inherited-configuration + rest :key #'first)) + (ignore-present (find :ignore-inherited-configuration + rest :key #'first))) + (when (and accept-present ignore-present) + (error "~A:~%Both ~S and ~S~%cannot exist in the same file.~%" + file + :accept-inherited-configuration + :ignore-inherited-configuration)) + (unless (or accept-present ignore-present) + (error "~A:~%One of ~S or ~S~%directives not found.~%" + file + :accept-inherited-configuration + :ignore-inherited-configuration))) + (loop :for dir :in rest + :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))) + (if recurse + (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) + (let* ((dirs (acquire-paths path recurse)) + ;; (file (when (file-exists-p path) path)) + ;; (paths (or dirs file)) + (paths dirs)) + (when paths + (setf (source-registry) + (append (source-registry) paths)) + (source-registry)))) + +(defun add-paths-to-source-registry (paths &optional recurse) + (loop + :for path :in paths + :collect (add-path-to-source-registry path recurse))) + +(defun collect-path (path &optional recurse) + (let* ((dirs (acquire-paths path recurse)) + ;; (file (when (file-exists-p path) path)) + ;; (p (or dir file) + (paths dirs)) + (when paths + paths))) + +(defun collect-paths (paths &optional recurse) + (loop + :for path :in paths + :nconc (collect-path path recurse))) + +(defun read-directive (directive) + (cond ((stringp directive) + (read-from-string directive)) + ((consp directive) + 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 +;; some shell-friendly text representation). The inheritted +;; configuration is provided in optional argument inherit, itself a +;; function that returns the previous configuration, with NIL +;; designating the default of #'ensure-source-registry. Internally, +;; initialize-source-registry-configuration can use this with a series +;; of functions for inheritted configuration. +(defun process-source-registry (directive &optional (inherit #'source-registry)) + (declare (ignorable inherit)) + (let ((reg (funcall inherit)) + (dir (read-directive directive))) + (declare (ignorable reg)) + (when dir + (destructuring-bind (type &rest rest) + dir + (ecase type + ((:include) + (process-source-registry-paths rest)) + ((:directory) + (collect-paths rest)) + ((:tree) + (collect-paths rest t)) + ((:default-registry) + (default-registry)) + ((:accept-inherited-configuration) + (when reg + (collect-paths reg))) + ((:ignore-inherited-configuration) + nil)))))) + +;; Will read the configuration and initialize all internal variables, +;; and return the new configuration. +(defun initialize-source-registry () + (let* ((sources (or (extract-registry-paths 'command-line) + (extract-registry-paths 'environment) + (extract-registry-paths 'files))) + (registry (process-source-registry-paths sources))) + (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))) + ;;;; ------------------------------------------------------------------------- ;;;; Cleanups after hot-upgrade. ;;;; Things to do in case we're upgrading from a previous version of ASDF.