Newer
Older
;;; Handle the Search Path for XCVB modules.
#+xcvb (module (:depends-on ("commands" "grain-registry")))
Francois-Rene Rideau
committed
;;; The Source Registry itself.
;;; We directly use the code from ASDF, therefore ensuring 100% compatibility.
(defparameter *flattened-source-registry* ()
Francois-Rene Rideau
committed
"Either NIL (for uninitialized), or a list of one element,
said element itself being a list of directory pathnames where to look for build.xcvb files")
(defparameter *source-registry-searched-p* nil
"Has the source registry been searched yet?")
(defparameter *builds*
(make-hash-table :test 'equal)
"A registry of known builds, indexed by canonical name.
Initially populated with all build.xcvb files from the search path.")
(defparameter *truename-build-fullnames*
(make-hash-table :test 'equal)
"A registry of known build fullnames, indexed by truename.
Initially populated with all build.xcvb files from the search path.")
;;; Special magic for build entries in the registry
(defmethod brc-pathnames ((build build-module-grain))
(list (grain-pathname build)))
(defmethod brc-pathnames ((build invalid-build-file))
(list (grain-pathname build)))
(defun make-invalid-ancestor-build-file (&key fullname pathname ancestor root)
(make-instance 'invalid-build-file
:root root
:fullname fullname
:pathname pathname
:reason (format nil "ancestor ~A at ~A is invalid because of~%~A~&"
(fullname ancestor)
pathname
(invalid-build-reason ancestor))))
(defmethod invalid-build-reason ((x build-registry-entry))
(format nil "a conflict between same-named builds at~%~{~S~&~}"
(brc-pathnames x)))
(defun pathname-build (pathname)
(loop :with truename = (truename pathname)
:for build :being :the :hash-values :of *builds* :do
(flet ((same-truename-p (pathname)
(equal (truename pathname) truename)))
(etypecase build
(when (same-truename-p (grain-pathname build))
(return build)))
(build-registry-conflict
(when (find-if #'same-truename-p (brc-pathnames build))
(error 'build-conflict
:fullname (fullname build)
:pathname pathname
:conflicts (remove-if #'same-truename-p (brc-pathnames build)))))))))
(defun compute-xcvb-source-registry (&optional parameter)
(let ((*default-pathname-defaults* (or *xcvb-lisp-directory* *default-pathname-defaults*)))
;; Check to see that if this envar is defined to a non-empty string
;; ensure that it is an absolute path to, not a relative one.
(handler-case
(asdf::flatten-source-registry parameter)
(error (c)
Peter Keller
committed
(user-error "Could not properly parse the source registry:~%~A" c)))))
Francois-Rene Rideau
committed
:sb-aclrepl
:sb-bsd-sockets
:sb-cltl2
:sb-concurrency
:sb-cover
:sb-grovel
:sb-introspect
:sb-md5
:sb-posix
:sb-queue
:sb-rotate-byte
:sb-rt
"special systems that are part of SBCL")
(defun initialize-builds ()
(log-format 10 "Initializing builds to supersede ASDF...~%")
(when (eq *lisp-implementation-type* :sbcl)
(loop :for x :in *sbcl-contribs*
:for n = (string-downcase x) :do
(log-format 10 " Initializing specific build to supersede ASDF: ~S~%"
n)
(setf (registered-build `(:supersedes-asdf ,n)) (make-require-grain :name n)))))
(defun initialize-xcvb-source-registry (&optional (parameter asdf:*source-registry-parameter*))
(setf asdf:*source-registry-parameter* parameter)
(log-format 10 "Initializing source registry: ")
(let ((source-registry (compute-xcvb-source-registry parameter)))
(setf *flattened-source-registry* (list source-registry))
(log-format-pp 10 "~S~%" *flattened-source-registry*))
(search-source-registry parameter))
Francois-Rene Rideau
committed
(defun assert-source-registry ()
(unless *flattened-source-registry*
Francois-Rene Rideau
committed
(error "You should have already initialized the source registry by now!")))
;;; Now for actually searching the source registry!
(defun finalize-source-registry ()
(log-format 10 "Finalizing (verifying) source registry~%")
(setf *flattened-source-registry*
Francois-Rene Rideau
committed
(list
(while-collecting (c)
(loop :with visited = (make-hash-table :test 'equal)
:for (path . flags) :in (car *flattened-source-registry*)
:for tn = (probe-file* path)
:for ns = (and tn (namestring tn)) :do
(cond
((not tn)
(log-format 7 " Discarding invalid path element ~S" path))
((gethash ns visited)
(log-format 7 " Discarding duplicate path element ~S" path))
(t
(log-format 8 " Verified path element: ~S ~S" path flags)
(setf (gethash ns visited) t)
(c (cons tn flags)))))))))
Francois-Rene Rideau
committed
(defvar +build-path+
(make-pathname :directory nil
Francois-Rene Rideau
committed
:name "build"
:type "xcvb"
:version :newest))
Francois-Rene Rideau
committed
(defun pathname-newest-version-p (x)
Francois-Rene Rideau
committed
(or
(member (pathname-version x) '(nil :newest :unspecific))
(and (integerp (pathname-version x))
(equal (truename x) (truename (make-pathname :version :newest :defaults x))))))
Francois-Rene Rideau
committed
(defun pathname-is-build.xcvb-p (x)
(and (equal (pathname-name x) "build")
(equal (pathname-type x) "xcvb")
Francois-Rene Rideau
committed
#+genera (pathname-newest-version-p x)))
(defun build.xcvb-in-directory (directory)
(merge-pathnames* +build-path+ directory))
(defun directory-has-build-file-p (directory)
(ignore-errors
(and (asdf::directory* (build.xcvb-in-directory directory)) t)))
(defun collect-sub*directories-with-build.xcvb
(directory &key
(exclude *default-source-registry-exclusions*)
collect)
(asdf::collect-sub*directories
directory
#'directory-has-build-file-p
#'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
collect))
(defun find-build-files-under (root)
(destructuring-bind (pathname &key recurse (exclude asdf::*default-source-registry-exclusions*))
root
Francois-Rene Rideau
committed
(if (not recurse)
(let ((path (probe-file (merge-pathnames* +build-path+ pathname))))
Francois-Rene Rideau
committed
(when path (list path)))
(mapcar 'build.xcvb-in-directory
(while-collecting (c)
(collect-sub*directories-with-build.xcvb
pathname :exclude exclude :collect #'c))))))
Francois-Rene Rideau
committed
(defun map-build-files-under (root fn)
"Call FN for all BUILD files under ROOT"
(log-format-pp
10 "Processing all build.xcvb files in source registry root:~% ~S~%"
root)
(let* ((builds (find-build-files-under root))
;; depth first traversal
(builds (sort (mapcar #'truename builds) #'<
:key (compose #'length #'pathname-directory))))
(map () fn builds)))
Francois-Rene Rideau
committed
(defun search-source-registry (&optional (parameter asdf:*source-registry-parameter*))
(log-format 10 "Searching for build files in source registry")
Francois-Rene Rideau
committed
(finalize-source-registry)
(dolist (root (car *flattened-source-registry*))
(log-format 10 " Searching for build files under ~S" root)
(map-build-files-under root #'(lambda (x) (register-build-file x root)))
(confirm-builds-under root))
(search-source-registry-asdf parameter)) ;; TODO: handle packages from Quicklisp?
(defun search-source-registry-asdf (&optional (parameter asdf:*source-registry-parameter*))
(asdf:initialize-source-registry parameter)
(loop :for name :being :the :hash-keys :of asdf::*source-registry*
:for fullname = `(:asdf ,name) :do
(register-build-named fullname (make-instance 'asdf-grain :name name) :asdf))
(unless (gethash "asdf" asdf::*source-registry*)
(setf (registered-build `(:supersedes-asdf "asdf")) (make-require-grain :name "asdf"))))
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
(defun ensure-source-registry-searched ()
(unless *source-registry-searched-p*
(search-source-registry)))
;;;; Registering a build
(defun supersedes-asdf-name (x)
Francois-Rene Rideau
committed
(let ((name (etypecase x
(string x)
(cons (car x)))))
`(:supersedes-asdf ,(coerce-asdf-system-name name))))
(defun registered-build (name &key ensure-build)
(let ((build (gethash name *builds*)))
(when ensure-build
(unless (build-module-grain-p build)
Francois-Rene Rideau
committed
(error "Could not find a build with requested fullname ~A. Try xcvb show-source-registry"
name)))
build))
(defun (setf registered-build) (build name &key ensure-build)
(when ensure-build
(unless (build-module-grain-p build)
(error "Cannot register build ~S to non-build grain ~S" name build)))
(setf (gethash name *builds*) build))
(defun fullname-from-truename (truename)
(gethash truename *truename-build-fullnames*))
(defun (setf fullname-from-truename) (fullname truename)
(setf (gethash truename *truename-build-fullnames*) fullname))
(defun register-build-file (build root)
"Registers build file build.xcvb (given as truename)
as having found under root path ROOT (as pathname),
for each of its registered names."
(log-format 10 " Registering build file ~S in ~S" build root)
(let* ((build-module-grain
(make-grain-from-file build :build-p t))
(fullname (when build-module-grain (fullname build-module-grain))))
(flet ((register-entry (entry)
(setf (gethash build *truename-build-fullnames*) (fullname entry))
(register-build-named fullname entry root)))
(cond
((null fullname)
(log-format 5 "Failed to parse build file at ~S" build))
((slot-boundp build-module-grain 'root)
(log-format 7 "Already visited build at ~S" build))
((typep (grain-parent build-module-grain) 'invalid-build-registry-entry)
(register-entry
(make-invalid-ancestor-build-file
:fullname fullname :pathname build :root root
:ancestor (grain-parent build-module-grain))))
(t
(setf (bre-root build-module-grain) root)
(register-entry build-module-grain))))
(values)))
(defun confirm-builds-under (root)
(log-format 10 "Confirming build files discovered under ~S" root)
;; This will try to register the secondary names of otherwise valid builds.
(loop
:with builds-under-root = (loop :for b :being :the :hash-values :of *builds*
:when (and (build-module-grain-p b) (equal (bre-root b) root))
:collect b)
;; Making sure we confirm parents before children, based on fullname length.
:for b :in (sort builds-under-root #'< :key (compose #'length #'fullname))
:for p = (grain-parent b) :do
(if (or (null p) (eq p (registered-build (fullname p))))
;; The parent has already been visited and has not been invalidated,
;; so the current build is valid, and we register its secondary names.
(dolist (name (append (mapcar #'canonicalize-fullname (nicknames b))
(mapcar #'supersedes-asdf-name (supersedes-asdf b))))
(register-build-named name b root))
(let* ((fullname (fullname b))
(invalid
(make-invalid-ancestor-build-file
:fullname fullname :pathname (grain-pathname b) :ancestor p :root root)))
(setf (registered-build fullname) invalid)))))
(defun merge-build (previous-build new-build name root)
;; Detect ambiguities.
;; If the name has already been registered, then
;; * if the previous entry is from a previous root, it has precedence
;; * else if the previous entry is from same root and is in an ancestor directory,
;; it has precedence
;; * otherwise, it's a conflict, and the name shall be marked as conflicted and
;; an error be printed if/when it is used.
;; Note: to do that in a more functional way, have some mechanism
;; that applies a modify-function to a gethash value, allowing (values NIL NIL) to specify remhash.
(check-type previous-build (or null invalid-build-registry-entry build-module-grain))
(cond
((null previous-build)
;; we're the first entry with that name. Bingo!
new-build)
((equal (bre-root previous-build) root)
;; There was a previous entry in same root:
;; there's an ambiguity, so that's a conflict!
(make-instance 'build-registry-conflict
:fullname name
:pathnames (cons (grain-pathname new-build) (brc-pathnames previous-build))
:root root))
(t
;; There was a previous entry in a previous root,
;; the previous entry takes precedence -- do nothing.
previous-build)))
(defun register-build-named (name build-module-grain root)
"Register under NAME pathname BUILD found in user-specified ROOT."
(funcallf (registered-build name) #'merge-build build-module-grain name root))
Francois-Rene Rideau
committed
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Show Search Path ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric build-string-description (entry fullname)
(:documentation "A human readable description of this grain"))
(defmethod build-string-description ((entry asdf-grain) fullname)
(assert (and (list-of-length-p 2 fullname) (eq (first fullname) :asdf)))
(let ((name (second fullname)))
(format nil "(:asdf ~S :directory ~S)" name
(pathname-directory-pathname
(nth-value 2 (asdf:locate-system name))))))
(defmethod build-string-description ((entry require-grain) fullname)
(assert (and (list-of-length-p 2 fullname) (eq (first fullname) :supersedes-asdf)))
(format nil "(:asdf ~S :superseded-by ~S)"
(second fullname) (fullname entry)))
(defmethod build-string-description ((entry build-module-grain) fullname)
(if (and (list-of-length-p 2 fullname) (eq (first fullname) :supersedes-asdf))
(let* ((nn (second (assoc (second fullname)
(asdf-supersessions (finalize-grain entry))
:test 'equal)))
(b (registered-build nn)))
(format nil "(:asdf ~S :superseded-by ~S)"
(second fullname) (if b `(:BUILD ,nn) `(:FASL ,nn))))
(format nil "(:build ~S :in-file ~S)"
fullname (namestring (grain-pathname entry)))))
(defmethod build-string-description ((entry invalid-build-file) fullname)
(format nil "(:invalid-build :with-fullname ~S :in-file ~S)"
fullname (grain-pathname entry)))
(defmethod build-string-description ((entry build-registry-conflict) fullname)
(format nil "(:invalid-build :registry-conflict ~S :among ~S)"
fullname (mapcar 'namestring (brc-pathnames entry))))
Francois-Rene Rideau
committed
(defun show-source-registry ()
"Show registered builds"
(let ((*print-case* :downcase))
(format t "~&;; Registered search paths:~%(:search-paths ~{~% ~S~})~%~%"
(car *flattened-source-registry*))
(format t ";; Builds found in the search paths:~%(:builds ")
(flet ((entry-string (x)
(destructuring-bind (fullname . entry) x
(build-string-description entry fullname))))
(format t "~{~% ~A~})~%"
(sort (mapcar #'entry-string
(hash-table->alist *builds*)) #'string<)))))
(define-command show-source-registry-command
(("show-source-registry" "source-registry" "ssr")
(&rest keys &key)
`(,@+source-registry-option-spec+
,@+verbosity-option-spec+)
"Show builds in the configured source registry"
"Show builds in the implicitly or explicitly configured source registry.
For debugging your XCVB configuration."
ignore)
(apply 'handle-global-options :use-target-lisp nil keys)
Francois-Rene Rideau
committed
(show-source-registry))
Francois-Rene Rideau
committed
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Find Module ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-command find-module
(("find-module" "fm")
(&rest keys &key)
`((("name" #\n) :type string :optional nil :list t :documentation "name to search for")
(("short" #\s) :type boolean :optional t :documentation "short output")
,@+source-registry-option-spec+
,@+verbosity-option-spec+)
"Show builds in the specified XCVB path"
"Show builds in the implicitly or explicitly specified XCVB path.
For debugging your XCVB configuration."
(name short))
(apply 'handle-global-options :use-target-lisp nil keys)
Francois-Rene Rideau
committed
(let ((all-good t))
(dolist (fullname name)
(let ((grain (resolve-absolute-module-name fullname)))
(cond
(grain
(if short
(format t "~A~%" (namestring (grain-pathname grain)))
(format t "Found ~S at ~S~%" (fullname grain) (namestring (grain-pathname grain)))))
(t
(format *error-output* "Could not find ~S. Check your paths with xcvb ssr.~%" fullname)
Francois-Rene Rideau
committed
(setf all-good nil)))))
(exit (if all-good 0 1))))