Commit e13e02ec authored by Eric Timmons's avatar Eric Timmons
Browse files

Allow .asds to be installed in global contexts

parent f5b49412
......@@ -38,17 +38,18 @@
(define-cli-command (("exec") *exec-ui*) (args options)
(let* ((context-name (config-value :context))
(context (get-context context-name))
(with-client (gethash :exec-with-client options))
(ignore-inherited (config-value :contexts context-name :ignore-inherited-source-registry))
(splice-inherited (uiop:getenvp "CL_SOURCE_REGISTRY"))
(source-registry (context-to-asdf-source-registry-form
context-name
context
:with-client with-client
:ignore-inherited ignore-inherited
:splice-inherited splice-inherited))
(output-translations (context-output-translations context-name))
(installed-system-names (sort (mapcar #'system-name (context-installed-systems context-name)) #'string<))
(visible-primary-system-names (sort (context-visible-primary-system-names context-name) #'string<)))
(output-translations (context-output-translations context))
(installed-system-names (sort (mapcar #'system-name (context-installed-systems context)) #'string<))
(visible-primary-system-names (sort (context-visible-primary-system-names context) #'string<)))
(with-standard-io-syntax
(execvpe (first args) (rest args)
`(("CL_SOURCE_REGISTRY" . ,(prin1-to-string source-registry))
......
......@@ -65,6 +65,14 @@ with version constraint).
:help "The name of the source to install from"
:reduce #'adopt:last))
(defparameter *option-install-asd*
(adopt:make-option
:install-asds
:long "asd"
:parameter "ASD-PATH"
:help "Install an .asd file into the context"
:reduce (adopt:flip #'cons)))
(defparameter *option-install-project*
(adopt:make-option
:install-projects
......@@ -102,6 +110,7 @@ with version constraint).
*option-install-version*
*option-install-source*
*option-install-project*
*option-install-asd*
*option-install-no-deps*
*option-yes*
*option-local*
......@@ -112,6 +121,7 @@ with version constraint).
(let* ((version-string (gethash :install-version options))
(system-specifiers args)
(project-specifiers (gethash :install-projects options))
(asd-files (gethash :install-asds options))
(source-name (gethash :install-source options))
(no-deps-p (gethash :install-no-deps options))
(context-name (config-value :context))
......@@ -119,6 +129,7 @@ with version constraint).
(ref (gethash :install-ref options)))
(install :projects project-specifiers
:systems system-specifiers
:asds (mapcar #'merge-pathnames asd-files)
:version version-string
:source source-name
:context context-name
......
......@@ -143,6 +143,10 @@ can be named, global contexts, or anonymous."))
in place with the same name. Return the new requirement if it was modified."
(let ((existing-req (context-find-requirement context (requirement-type-keyword req)
(requirement-name req))))
(when (typep req 'fs-system-file-requirement)
(fs-source-register-asd (context-fs-source context) (requirement-name req)))
(when (typep req 'fs-system-requirement)
(fs-source-register-asd (context-fs-source context) (requirement-pathname req)))
(if existing-req
(progn
(log:debug "Replacing requirement ~A with ~A" existing-req req)
......@@ -320,38 +324,38 @@ in place with the same name. Return the new requirement if it was modified."
(defmethod process-form (context (section (eql :requirements)) form)
(destructuring-bind (type &key name version source branch tag commit ref pathname no-deps-p) form
(push (cond
((eql type :asd-system)
(make-instance 'fs-system-requirement
:name name
:pathname pathname
:no-deps-p no-deps-p
:why t))
((eql type :asd-file)
(make-instance 'fs-system-file-requirement
:name pathname
:no-deps-p no-deps-p
:why t))
((or branch tag commit ref)
(make-instance 'vcs-project-requirement
:name name
:source (get-source source)
:commit commit
:branch branch
:tag tag
:ref ref
:no-deps-p no-deps-p
:why t))
(t
(make-instance (ecase type
(:system 'system-requirement)
(:project 'project-requirement))
:name name
:source (get-source source)
:version-spec version
:no-deps-p no-deps-p
:why t)))
(context-requirements context))))
(context-add-requirement! context
(cond
((eql type :asd-system)
(make-instance 'fs-system-requirement
:name name
:pathname pathname
:no-deps-p no-deps-p
:why t))
((eql type :asd-file)
(make-instance 'fs-system-file-requirement
:name name
:no-deps-p no-deps-p
:why t))
((or branch tag commit ref)
(make-instance 'vcs-project-requirement
:name name
:source (get-source source)
:commit commit
:branch branch
:tag tag
:ref ref
:no-deps-p no-deps-p
:why t))
(t
(make-instance (ecase type
(:system 'system-requirement)
(:project 'project-requirement))
:name name
:source (get-source source)
:version-spec version
:no-deps-p no-deps-p
:why t))))))
(defmethod process-form (context (section (eql :releases)) form)
(destructuring-bind (name &key version source systems) form
......@@ -457,12 +461,11 @@ in place with the same name. Return the new requirement if it was modified."
(format stream ":releases~%")
(dolist (release (sort (copy-list (context-releases context)) #'string<
:key (compose #'project-name #'release-project)))
(unless (typep release 'fs-release)
(format stream "~S~%"
(context-release-to-form release (remove-if-not (lambda (x)
(eql x release))
(context-system-releases context)
:key #'system-release-release)))))
(format stream "~S~%"
(context-release-to-form release (remove-if-not (lambda (x)
(eql x release))
(context-system-releases context)
:key #'system-release-release))))
(terpri stream)
(terpri stream)
......
......@@ -81,7 +81,7 @@
:version-spec version-spec
common-args))))))
(defun install (&key projects systems
(defun install (&key projects systems asds
version ref source
no-deps-p
(validate (constantly t))
......@@ -93,6 +93,9 @@ PROJECTS and SYSTEMS must be lists of dependency specifiers. VERSION, REF, and
SOURCE must be strings and are used as the default constraints on PROJECTS and
SYSTEMS if such constraints cannot be extracted from the specifiers themselves.
ASDs must be a list of pathnames to .asd files. All systems in each .asd file
will be installed.
VALIDATE must be a function of one argument (a diff) and returns non-NIL if the
install should proceed."
(with-clpm-session ()
......@@ -103,7 +106,13 @@ install should proceed."
(mapcar (rcurry #'make-requirement
:system
:version version :source source :ref ref :no-deps-p no-deps-p)
systems))))
systems)
(mapcar (lambda (x)
(make-instance 'fs-system-file-requirement
:name x
:why t
:no-deps-p no-deps-p))
asds))))
(install-requirements reqs :context context :validate validate :save-context-p save-context-p))))
(defun install-requirements (reqs &key
......
......@@ -232,13 +232,13 @@ represents."))
(defmethod requirement-to-plist ((req fs-system-requirement))
(append
(list :pathname (requirement-pathname req)
(list :pathname (namestring (requirement-pathname req))
:name (requirement-name req))
(awhen (requirement-no-deps-p req)
(list :no-deps-p it))))
(defmethod requirement-to-plist ((req fs-system-file-requirement))
(append
(list :pathname (requirement-pathname req))
(list :name (namestring (requirement-name req)))
(awhen (requirement-no-deps-p req)
(list :no-deps-p it))))
......@@ -100,19 +100,19 @@
"Given a context, return a new context that has the same requirements but the
set of installed releases is updated to be the minimum set that satisfies all
the requirements."
(let* ((*sources* (context-sources context))
(*releases-sort-function* (unless (eql update-projects t)
(make-result-sorter context update-projects)))
(reqs (rewrite-vcs-reqs (context-requirements context) context update-projects))
(out-context (copy-context context))
(root-node (make-instance 'node
:unresolved-reqs reqs
:groveler (make-groveler)))
(final-node (perform-search root-node)))
(setf (context-releases out-context)
(mapcar #'car (node-activated-releases final-node)))
(setf (context-reverse-dependencies out-context)
(sort (copy-alist (node-activated-releases final-node))
#'string< :key (compose #'project-name #'release-project #'car)))
(setf (context-system-releases out-context) (node-activated-system-releases final-node))
out-context))
(with-sources ((context-sources context))
(let* ((*releases-sort-function* (unless (eql update-projects t)
(make-result-sorter context update-projects)))
(reqs (rewrite-vcs-reqs (context-requirements context) context update-projects))
(out-context (copy-context context))
(root-node (make-instance 'node
:unresolved-reqs reqs
:groveler (make-groveler)))
(final-node (perform-search root-node)))
(setf (context-releases out-context)
(mapcar #'car (node-activated-releases final-node)))
(setf (context-reverse-dependencies out-context)
(sort (copy-alist (node-activated-releases final-node))
#'string< :key (compose #'project-name #'release-project #'car)))
(setf (context-system-releases out-context) (node-activated-system-releases final-node))
out-context)))
......@@ -6,16 +6,12 @@
(uiop:define-package #:clpm/resolve/defs
(:use #:cl
#:clpm/log)
(:export #:*sources*
#:provided-system-p))
(:export #:provided-system-p))
(in-package #:clpm/resolve/defs)
(setup-logger)
(defvar *sources* nil
"The sources that can be used during resolution.")
(defparameter *sb-contribs*
'("sb-aclrepl" "sb-bsd-sockets" "sb-capstone" "sb-cltl2" "sb-concurrency" "sb-cover"
"sb-executable" "sb-gmp" "sb-grovel" "sb-introspect" "sb-md5" "sb-mpfr" "sb-posix"
......
......@@ -27,13 +27,13 @@
(defun find-project-source (project-name)
(loop
:for source :in *sources*
:for source :in (sources)
:when (source-project source project-name nil)
:do (return source)))
(defun find-system-source (system-name)
(loop
:for source :in *sources*
:for source :in (sources)
:when (source-system source system-name nil)
:do (return source)))
......@@ -52,19 +52,19 @@ to searching."
(error "Unable to find a source for requirement ~S" req)))))
(defmethod find-requirement-source ((req project-requirement) &optional errorp)
"Find the first source in *SOURCES* that provides the project. ERRORP is
"Find the first source in (SOURCES) that provides the project. ERRORP is
handled by an :AROUND method."
(declare (ignore errorp))
(find-project-source (requirement-name req)))
(defmethod find-requirement-source ((req system-requirement) &optional errorp)
"Find the first source in *SOURCES* that provides the system. ERRORP is andled
"Find the first source in (SOURCES) that provides the system. ERRORP is andled
by an :AROUND method."
(declare (ignore errorp))
(find-system-source (requirement-name req)))
(defmethod find-requirement-source ((req vcs-project-requirement) &optional errorp)
"Find the first source in *SOURCES* that provides the project. ERRORP is
"Find the first source in (SOURCES) that provides the project. ERRORP is
handled by an :AROUND method."
(declare (ignore errorp))
(find-project-source (requirement-name req)))
......@@ -83,7 +83,7 @@ satisfied. Returns one of :SAT, :UNSAT, or :UNKNOWN."))
((not system-release)
:unknown)
((not (eql (system-release-source system-release)
(requirement-source req)))
(get-source :implicit-file)))
:unsat)
(t
:sat))))
......@@ -150,7 +150,7 @@ a plist. This plist can contain :system-releases or :system-files."))
(defmethod resolve-requirement ((req fs-system-requirement) node)
;; Make a release from the file system.
(let* ((system-name (requirement-name req))
(fs-source (requirement-source req))
(fs-source (get-source :implicit-file))
(system (source-system fs-source system-name))
(releases (system-releases system))
(release (first releases))
......@@ -164,7 +164,7 @@ a plist. This plist can contain :system-releases or :system-files."))
(defmethod resolve-requirement ((req fs-system-file-requirement) node)
;; Make a release from the file system.
(let* ((asd-pathname (requirement-name req))
(fs-source (requirement-source req))
(fs-source (get-source :implicit-file))
(release (source-project-release fs-source (namestring asd-pathname) :newest)))
(list (list release
:system-files (list (cons (release-system-file release asd-pathname) t))))))
......
......@@ -74,7 +74,7 @@ source using FS-SOURCE-REGISTER-ASD."))
t)
(defmethod source-project ((source fs-source) project-name &optional (error t))
(or (gethash project-name (fs-source-projects-by-namestring source))
(or (gethash (namestring project-name) (fs-source-projects-by-namestring source))
(when error
(error 'source-missing-project
:source source
......@@ -112,7 +112,8 @@ can be relative or absolute."
(namestring-ht (fs-source-system-files-by-namestring fs-source))
(namestring (namestring asd-pathname))
(project-ht (fs-source-projects-by-namestring fs-source))
(project (make-instance 'fs-project :name namestring :source fs-source)))
(project (or (gethash namestring project-ht)
(make-instance 'fs-project :name namestring :source fs-source))))
(setf (gethash namestring project-ht) project)
(aprog1 (ensure-gethash (pathname-name namestring) primary-name-ht
(make-instance 'fs-system-file
......@@ -127,7 +128,7 @@ can be relative or absolute."
(let* ((system-files (hash-table-keys (fs-source-projects-by-namestring source))))
`(,(source-name source)
:type :file-system
:system-files ,(mapcar #'system-file-asd-enough-namestring system-files))))
:system-files ,system-files)))
(defmethod sync-source ((source fs-source))
nil)
......@@ -189,7 +190,7 @@ of this created upon instantiation."))
"Look at the fs-source to get the system file."
(let* ((source (release-source release))
(ht (fs-source-system-files-by-namestring source)))
(gethash system-file-namestring ht)))
(gethash (namestring system-file-namestring) ht)))
(defmethod release-system-files ((release fs-release))
"Projects (and releases) correspond to a single system file."
......
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