Commit 25a925d2 authored by Eric Timmons's avatar Eric Timmons
Browse files

Update client for latest changes

parent 1ba65393
......@@ -12,9 +12,10 @@
"The behavior if ASDF is unable to find a system and CLPM's ASDF integration
is active. One of:
+ :ERROR :: Signal a MISSING-SYSTEM condition. The restarts
RELOAD-CONTEXT-CONFIG, INSTALL-AND-RELOAD-CONTEXT-CONFIG, and
INSTALL-WITHOUT-DEPENDENCIES-AND-RELOAD-CONTEXT-CONFIG will be available.
+ :ERROR :: (default) Signal a MISSING-SYSTEM condition. The restarts
INSTALL-AND-RELOAD-CONFIG, RERESOLVE-REQUIREMENTS-AND-RELOAD-CONFIG,
INSTALL-WITHOUT-DEPENDENCIES-AND-RELOAD-CONFIG, and RELOAD-CONFIG will be
available.
+ :INSTALL :: Install the system and its dependencies without prompting. If the
active context is a bundle, the system is currently not added to the bundle (you
......@@ -41,24 +42,31 @@ to some other included system for this to have any effect).
(:documentation
"A condition signaled when CLPM thinks a system is not installed."))
(defun reload-context-config (&optional condition)
"Invoke the RELOAD-CONTEXT-CONFIG restart or return NIL if the restart does
not exist."
(let ((restart (find-restart 'reload-context-config condition)))
(defun reload-config (&optional condition)
"Invoke the RELOAD-CONFIG restart or return NIL if the restart does not
exist."
(let ((restart (find-restart 'reload-config condition)))
(when restart
(invoke-restart restart))))
(defun install-and-reload-context-config (&optional condition)
"Invoke the INSTALL-AND-RELOAD-CONTEXT-CONFIG restart or return NIL if the
restart does not exist."
(let ((restart (find-restart 'install-and-reload-context-config condition)))
(defun install-and-reload-config (&optional condition)
"Invoke the INSTALL-AND-RELOAD-CONFIG restart or return NIL if the restart
does not exist."
(let ((restart (find-restart 'install-and-reload-config condition)))
(when restart
(invoke-restart restart))))
(defun install-without-dependencies-and-reload-context-config (&optional condition)
"Invoke the INSTALL-WITHOUT-DEPENDENCIES-AND-RELOAD-CONTEXT-CONFIG restart or
return NIL if the restart does not exist."
(let ((restart (find-restart 'install-without-dependencies-and-reload-context-config condition)))
(defun install-without-dependencies-and-reload-config (&optional condition)
"Invoke the INSTALL-WITHOUT-DEPENDENCIES-AND-RELOAD-CONFIG restart or return
NIL if the restart does not exist."
(let ((restart (find-restart 'install-without-dependencies-and-reload-config condition)))
(when restart
(invoke-restart restart))))
(defun reresolve-requirements-and-reload-config (&optional condition)
"Invoke the RERESOLVE-REQUIREMENTS-AND-RELOAD-CONFIG restart or return NIL if
the restart does not exist."
(let ((restart (find-restart 'reresolve-requirements-and-reload-config condition)))
(when restart
(invoke-restart restart))))
......@@ -91,13 +99,17 @@ recursion."
(asdf:initialize-source-registry source-registry))
(defun handle-missing-system (system-name active-context)
(flet ((%install (no-deps)
(let ((new-source-registry
(install :systems (unless (context-bundle-p active-context) (list system-name))
:no-deps no-deps
:update-asdf-config t)))
(when new-source-registry
(find-system-without-clpm system-name)))))
(labels ((%do-install (systems no-deps)
(let ((new-source-registry
(install :systems systems
:no-deps no-deps
:update-asdf-config t)))
(when new-source-registry
(find-system-without-clpm system-name))))
(%reresolve ()
(%do-install nil nil))
(%install (no-deps)
(%do-install (unless (context-bundle-p active-context) (list system-name)) no-deps)))
(ecase *asdf-system-not-found-behavior*
(:install (%install nil))
(:install-without-deps (%install t))
......@@ -106,31 +118,25 @@ recursion."
;; Prevent RESTART-CASE from using WITH-CONDITION-RESTARTS,
;; otherwise things can get messed up for defsystem-depends-on
(signal-missing-system system-name)
(reload-context-config ()
(reresolve-requirements-and-reload-config ()
:report "Reresolve requirements and try again."
(%reresolve))
(reload-config ()
:report "Reload the source registry for the context and try again."
(asdf-configure-source-registry (context-source-registry :context active-context))
(unless (context-bundle-p active-context)
(setf *active-context-installed-systems* (context-installed-system-names active-context)
*active-context-visible-primary-system-names* (context-visible-primary-system-names active-context)))
(setf *active-context-installed-systems* (context-installed-system-names :context active-context)
*active-context-visible-primary-system-names* (context-visible-primary-system-names :context active-context)))
(asdf:search-for-system-definition system-name))
(install-and-reload-context-config ()
(install-and-reload-config ()
:report "Attempt to install the system and try again."
(%install nil))
(install-without-dependencies-and-reload-context-config ()
(install-without-dependencies-and-reload-config ()
:report "Attempt to install the system without dependencies and try again."
(%install t))))
((nil)
nil))))
;; TODO: 0.4
;;
;; This function will either become moot or need to be drastically reworked. If
;; global contexts and bundles become more unified, then global contexts will
;; also have the ability to "install" systems in an "editable" mode (the context
;; uses the source code in a user editable location on the file system). If this
;; happens, then it's possible that editable system gained a new requirement and
;; we wouldn't want to touch the top level user requirements at all if the
;; system was brought in that way.
(defun clpm-system-definition-pre-search (system-name)
"When used in conjunction with CLPM-SYSTEM-DEFINITION-SEARCH, this creates a
poor man's :around method for locating systems. This function checks to see if
......@@ -139,7 +145,7 @@ that's not installed, but is visible in the the source registry for the active
context.
This happens because the smallest granularity availble in ASDF's source registry
is including directories. So, for instance, someone may install CFFI (defined in
is the directory. So, for instance, someone may install CFFI (defined in
cffi.asd). Then, some time later, they decide they want to run CFFI's tests,
defined by the system cffi-tests in cffi-tests.asd *in the same directory as
cffi.asd*. The cffi-tests system will be found by ASDF, but its dependencies,
......@@ -154,6 +160,7 @@ requirement."
(not (equal "asdf" primary-name))
(not (equal "uiop" primary-name))
(not (member system-name *active-context-installed-systems* :test #'equal))
(not (member primary-name *active-context-editable-primary-system-names* :test #'equal))
(member primary-name *active-context-visible-primary-system-names* :test #'equal))
(handle-missing-system system-name active-context))))
......
......@@ -14,67 +14,5 @@ CLPMFILE) to the new clpmfile."
proc
`(with-bundle-default-pathname-defaults (,clpmfile)
(with-bundle-local-config (,clpmfile)
(bundle-init ,clpmfile :asds ',asds)))))
(bundle-init :clpmfile ,clpmfile :asds ',asds)))))
clpmfile)
(defun bundle-install (&key clpmfile no-resolve (validate 'context-diff-approved-p))
"Ensure a bundle is installed. Returns a source registry form if the install completed.
CLPMFILE must be a pathname pointing a clpmfile.
If NO-RESOLVE is non-NIL, then the bundle will be installed completely from its
lock file, without reresolving any requirements.
VALIDATE is a function that takes a CONTEXT-DIFF instance and returns non-NIL if
the diff is approved and the install can continue. If NIL, the install is
aborted."
(let (diff-description)
(with-clpm-proc (proc)
(clpm-proc-print
proc
`(with-bundle-default-pathname-defaults (,clpmfile)
(with-bundle-local-config (,clpmfile)
(bundle-source-registry
(bundle-install ,clpmfile
:validate ,(make-diff-validator-fun)
:no-resolve ,no-resolve)))))
(setf diff-description (clpm-proc-read proc))
(let ((validate-result (funcall validate (make-context-diff-from-description diff-description)))
source-registry)
(clpm-proc-print proc validate-result)
(setf source-registry (clpm-proc-read proc))
(when validate-result
(clpm-proc-print proc
`(with-bundle-default-pathname-defaults (,clpmfile)
(with-bundle-local-config (,clpmfile)
(let ((bundle-context (bundle-context ,clpmfile)))
(print (mapcar 'system-name (context-installed-systems bundle-context)))
(context-visible-primary-system-names bundle-context)))))
(values source-registry (clpm-proc-read proc) (clpm-proc-read proc)))))))
(defun bundle-update (&key projects systems clpmfile (validate 'context-diff-approved-p))
"Update a bundle.
PROJECTS is a list of projects to update. SYSTEMS is a list of systems to
update. If both are NIL, all projects are available for updating.
CLPMFILE must be a pathname pointing a clpmfile.
VALIDATE is a function that takes a CONTEXT-DIFF instance and returns non-NIL if
the diff is approved and the install can continue. If NIL, the install is
aborted."
(let (diff-description)
(with-clpm-proc (proc)
(clpm-proc-print
proc
`(with-bundle-default-pathname-defaults (,clpmfile)
(with-bundle-local-config (,clpmfile)
(bundle-update ,clpmfile
:update-systems ',systems
:update-projects ',projects
:validate ,(make-diff-validator-fun)))))
(setf diff-description (clpm-proc-read proc))
(let ((validate-result (funcall validate (make-context-diff-from-description diff-description))))
(clpm-proc-print proc validate-result)
(clpm-proc-read proc)
validate-result))))
......@@ -20,4 +20,5 @@
(:file "package")
(:file "proc" :depends-on ("package"))
(:file "ui" :depends-on ("package"))
(:file "update" :depends-on ("package" "proc"))
(:file "version" :depends-on ("package" "proc"))))
......@@ -19,6 +19,9 @@ string (naming a global CLPM context) or a pathname to a clpmfile.")
"If non-NIL, will be spliced into source registry if inherited config is not
ignored.")
(defvar *active-context-editable-primary-system-names* nil
"List of systems installed in the active context via an editable requirement.")
(defvar *active-context-installed-systems* nil
"List of systems installed in the active context.")
......@@ -28,28 +31,33 @@ ignored.")
(defun configure-from-env ()
"Determine if there is any active context by looking at environment
variables."
(let ((env-clpmfile (uiop:getenvp "CLPM_BUNDLE_CLPMFILE"))
(let ((env-clpmfile (uiop:getenvp "CLPM_EXEC_CLPMFILE"))
(env-context (uiop:getenvp "CLPM_EXEC_CONTEXT")))
(cond
(env-clpmfile
;; We're operating within a bundle context.
(setf *active-context* (pathname env-clpmfile))
(setf *active-context-ignore-inherited-source-registry* t))
(env-context
;; We're operating within a global CLPM context.
(setf *active-context* env-context)
(setf *active-context-ignore-inherited-source-registry*
(uiop:getenvp "CLPM_EXEC_IGNORE_INHERITED_SOURCE_REGISTRY"))
(setf *active-context-splice-source-registry*
(uiop:getenvp "CLPM_EXEC_SPLICE_INHERITED_SOURCE_REGISTRY"))
(setf *active-context-installed-systems* (uiop:split-string (uiop:getenv "CLPM_EXEC_INSTALLED_SYSTEMS")))
(setf *active-context-visible-primary-system-names* (uiop:split-string (uiop:getenv "CLPM_EXEC_VISIBLE_PRIMARY_SYSTEMS")))))))
(when (or env-clpmfile env-context)
(setf *active-context* (if env-clpmfile (pathname env-clpmfile) env-context))
(uiop:if-let ((installed-systems-string (uiop:getenvp "CLPM_EXEC_INSTALLED_SYSTEMS")))
(uiop:with-safe-io-syntax ()
(setf *active-context-installed-systems* (read-from-string installed-systems-string))))
(uiop:if-let ((visible-systems-string (uiop:getenvp "CLPM_EXEC_VISIBLE_PRIMARY_SYSTEMS")))
(uiop:with-safe-io-syntax ()
(setf *active-context-visible-primary-system-names* (read-from-string visible-systems-string))))
(uiop:if-let ((editable-systems-string (uiop:getenvp "CLPM_EXEC_EDITABLE_PRIMARY_SYSTEMS")))
(uiop:with-safe-io-syntax ()
(setf *active-context-editable-primary-system-names* (read-from-string editable-systems-string))))
(if (uiop:getenvp "CLPM_EXEC_IGNORE_INHERITED_SOURCE_REGISTRY")
(progn
(setf *active-context-ignore-inherited-source-registry* t)
(setf *active-context-splice-source-registry* nil))
(progn
(setf *active-context-ignore-inherited-source-registry* nil)
(setf *active-context-splice-source-registry* (uiop:getenvp "CLPM_EXEC_SPLICE_INHERITED_SOURCE_REGISTRY")))))))
(uiop:register-image-restore-hook 'configure-from-env)
(defun clear-active-context ()
(setf *active-context* nil
*active-context-ignore-inherited-source-registry* nil
*active-context-splice-source-registry* nil
*active-context-visible-primary-system-names* nil
*active-context-installed-systems* nil
*active-context-visible-primary-system-names* nil))
(uiop:register-image-dump-hook 'clear-active-context)
......@@ -69,83 +77,64 @@ context."
"Returns the default context for operations. Defaults to *DEFAULT-CONTEXT*,
then ACTIVE-CONTEXT, then \"default\"."
(or *default-context*
*active-context*
(active-context)
"default"))
(defun context-bundle-p (context)
"A context names a bundle if it is a pathname."
(pathnamep context))
(defun context-asd-pathnames (&optional (context (default-context)))
(defun context-asd-pathnames (&key (context (default-context)))
"Given a context, return a list of pathnames to .asd files installed in that
context."
(assert (not (context-bundle-p context)))
(with-clpm-proc (proc)
(clpm-proc-print
proc
`(context-asd-pathnames ,context))
(clpm-proc-print proc `(asd-pathnames :context ,context))
(clpm-proc-read proc)))
(defun context-asd-directories (&optional (context (default-context)))
"Return the directories containing the .asd files installed in CONTEXT."
(asd-pathnames-to-directories (context-asd-pathnames context)))
(defun asd-pathnames-to-directories (pathnames)
"Given a list of pathnames to .ASD files, return a list of pathnames to the
directories containing the files."
(remove-duplicates (mapcar 'uiop:pathname-directory-pathname pathnames)
:test 'uiop:pathname-equal))
(defun context-find-system-asd-pathname (system-name &optional (context (default-context)))
(defun context-asd-directories (&key (context (default-context)))
"Return the directories containing the .asd files installed in CONTEXT."
(asd-pathnames-to-directories (context-asd-pathnames :context context)))
(defun context-editable-primary-system-names (&key (context (default-context)))
"Return the names of primary systems editable in CONTEXT."
(with-clpm-proc (proc)
(clpm-proc-print proc `(editable-primary-system-names :context ,context))
(clpm-proc-read proc)))
(defun context-find-system-asd-pathname (system-name &key (context (default-context)))
"Find the pathname to a system in the given context."
(assert (not (context-bundle-p context)))
(with-clpm-proc (proc)
(clpm-proc-print
proc
`(context-find-system-asd-pathname ,context ,system-name))
(clpm-proc-print proc `(find-system-asd-pathname ,system-name :context ,context))
(clpm-proc-read proc)))
(defun context-installed-system-names (&optional (context (default-context)))
"Return the names of systems installed in CONTEXT. Does not currently work on
bundles."
(assert (not (context-bundle-p context)))
(defun context-installed-system-names (&key (context (default-context)))
"Return the names of systems installed in CONTEXT."
(with-clpm-proc (proc)
(clpm-proc-print proc
`(mapcar 'system-name (context-installed-systems ,context)))
(clpm-proc-print proc `(installed-system-names :context ,context))
(clpm-proc-read proc)))
(defun context-visible-primary-system-names (&optional (context (default-context)))
"Return the names of primary systems visible to ASDF in CONTEXT. Does not
currently work on bundles."
(assert (not (context-bundle-p context)))
(defun context-visible-primary-system-names (&key (context (default-context)))
"Return the names of primary systems visible to ASDF in CONTEXT."
(with-clpm-proc (proc)
(clpm-proc-print proc
`(context-visible-primary-system-names ,context))
(clpm-proc-print proc `(visible-primary-system-names :context ,context))
(clpm-proc-read proc)))
(defun context-output-translations (&optional (context (default-context)))
(defun context-output-translations (&key (context (default-context)))
"Return an output-translations form for CONTEXT."
(with-clpm-proc (proc)
(clpm-proc-print
proc
(if (context-bundle-p context)
`(with-bundle-default-pathname-defaults (,@(when (pathnamep context) (list context)))
(with-bundle-local-config (,@(when (pathnamep context) (list context)))
(bundle-output-translations ,(if (pathnamep context) context '(bundle-clpmfile-pathname)))))
`(context-output-translations ,context)))
(clpm-proc-print proc `(output-translations :context ,context))
(clpm-proc-read proc)))
(defun context-source-registry (&key (context (default-context)) ignore-inherited)
"Return a source-registry form for the CONTEXT."
(with-clpm-proc (proc)
(clpm-proc-print
proc
(if (context-bundle-p context)
`(with-bundle-default-pathname-defaults (,context)
(with-bundle-local-config (,context)
(bundle-source-registry ,context)))
`(context-to-asdf-source-registry-form ,context
:ignore-inherited ,ignore-inherited)))
(clpm-proc-print proc `(source-registry :context ,context :ignore-inherited-source-registry ,ignore-inherited))
(clpm-proc-read proc)))
(defun activate-context (context &key activate-asdf-integration
......@@ -166,18 +155,20 @@ called."
(cerror "Continue" "You are attempting to activate a context when a context is already active."))
(let ((source-registry (context-source-registry :context context
:ignore-inherited ignore-inherited-source-registry))
(output-translations (context-output-translations context))
(output-translations (context-output-translations :context context))
(old-context (active-context)))
(setf *active-context* context
*active-context-ignore-inherited-source-registry* ignore-inherited-source-registry
*active-context-installed-systems* nil
*active-context-visible-primary-system-names* nil)
*active-context-visible-primary-system-names* nil
*active-context-editable-primary-system-names* nil)
(unless old-context
(setf *active-context-splice-source-registry* asdf:*source-registry-parameter*))
(asdf-configure-source-registry source-registry)
(unless (context-bundle-p context)
(setf *active-context-installed-systems* (context-installed-system-names context)
*active-context-visible-primary-system-names* (context-visible-primary-system-names context)))
(setf *active-context-editable-primary-system-names* (context-editable-primary-system-names :context context)
*active-context-installed-systems* (context-installed-system-names :context context)
*active-context-visible-primary-system-names* (context-visible-primary-system-names :context context)))
(when output-translations
(asdf:initialize-output-translations output-translations))
(when activate-asdf-integration
......
......@@ -40,47 +40,12 @@
"Returns non-NIL if DIFF contains no changes."
(null (context-diff-release-diffs diff)))
(defun make-added-release-diff-from-description (desc)
(destructuring-bind (project-name &key version source)
desc
(make-instance 'release-diff
:project-name project-name
:new-version version
:new-source source)))
(defun make-removed-release-diff-from-description (desc)
(destructuring-bind (project-name &key version source)
desc
(make-instance 'release-diff
:project-name project-name
:old-version version
:old-source source)))
(defun make-changed-release-diff-from-description (desc)
(destructuring-bind (project-name &key old new)
desc
(destructuring-bind (&key ((:version old-version)) ((:source old-source)))
old
(destructuring-bind (&key ((:version new-version)) ((:source new-source)))
new
(make-instance 'release-diff
:project-name project-name
:old-version old-version
:old-source old-source
:new-version new-version
:new-source new-source)))))
(defun make-context-diff-from-description (desc)
(destructuring-bind (&key added-releases removed-releases changed-releases)
(destructuring-bind (&key releases)
desc
(make-instance 'context-diff
:release-diffs
(sort (append
(mapcar #'make-added-release-diff-from-description added-releases)
(mapcar #'make-removed-release-diff-from-description removed-releases)
(mapcar #'make-changed-release-diff-from-description changed-releases))
#'string<
:key #'release-diff-project-name))))
(mapcar (lambda (x) (apply #'make-instance 'release-diff x)) releases))))
(defun context-diff-column-widths (diff)
"Returns a list of 5 integers detailing the column widths needed to print a
......
......@@ -11,11 +11,13 @@
(validate 'context-diff-approved-p)
no-deps
(context (default-context))
(update-asdf-config (asdf-integration-active-p)))
"Install a set of projects and systems. If the install completed, returns
three values. The first is a source registry form, the second is a list of
systems installed in the context, and the third is a list of primary system
names visible when that source registry form is used.
(update-asdf-config (asdf-integration-active-p))
no-resolve)
"Install a set of projects and systems. If the install completed, returns four
values. The first is a source registry form, the second is a list of systems
installed in the context, the third is a list of primary system names visible
when that source registry form is used, and the fourth is a list of primary
system names that are editable in the context.
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
......@@ -24,41 +26,43 @@ SYSTEMS if such constraints cannot be extracted from the specifiers themselves.
VALIDATE must be a function of one argument (a diff) and returns non-NIL if the
install should proceed.
NO-RESOLVE only has an effect if the CONTEXT is a bundle. If it is non-NIL, then
the bundle will be installed completely from its lock file, without reresolving
any requirements.
If UPDATE-ASDF-CONFIG is non-NIL and CONTEXT is the active context, then ASDF's
source registry is updated with the results."
(when (and (context-bundle-p context)
(or projects systems))
(error "INSTALL currently only accepts NIL for PROJECTS and SYSTEMS when working on bundles."))
(multiple-value-bind
(source-registry installed-system-names visible-primary-system-names)
(if (context-bundle-p context)
(bundle-install :validate validate :clpmfile context)
(let (diff-description)
(with-clpm-proc (proc)
(clpm-proc-print
proc
`(context-to-asdf-source-registry-form
(install :projects ',(ensure-list projects)
:systems ',(ensure-list systems)
:no-deps-p ,no-deps
:context ,context
:save-context-p t
:validate ,(make-diff-validator-fun)
:version ,version
:ref ,ref
:source ,source)))
(setf diff-description (clpm-proc-read proc))
(let ((validate-result (funcall validate (make-context-diff-from-description diff-description)))
source-registry)
(clpm-proc-print proc validate-result)
(setf source-registry (clpm-proc-read proc))
(when validate-result
(clpm-proc-print proc `(mapcar 'system-name (context-installed-systems ,context)))
(clpm-proc-print proc `(context-visible-primary-system-names ,context))
(values source-registry (clpm-proc-read proc) (clpm-proc-read proc)))))))
(when (and update-asdf-config (equal context (active-context)))
(asdf-configure-source-registry source-registry)
(unless (context-bundle-p context)
(with-clpm-proc (proc)
(clpm-proc-print
proc
`(with-clpm-session ()
;; Use a symbol that we know is going to be present in the CLPM package.
,(if (context-bundle-p context)
`(bundle-install :clpmfile ,context :validate ,(make-diff-validator-fun)
:no-resolve ,no-resolve)
`(install :projects ',(ensure-list projects)
:systems ',(ensure-list systems)
:no-deps-p ,no-deps
:context ,context
:save-context-p t
:validate ,(make-diff-validator-fun)
:version ,version
:ref ,ref
:source ,source))
(list (source-registry :context ,context)
(installed-system-names :context ,context)
(visible-primary-system-names :context ,context)
(editable-primary-system-names :context ,context))))
(clpm-proc-print proc
(funcall validate (make-context-diff-from-description (clpm-proc-read proc))))
(destructuring-bind (source-registry installed-system-names visible-system-names editable-system-names)
(clpm-proc-read proc)
(when (and update-asdf-config (equal context (active-context)))
(asdf-configure-source-registry source-registry)
(setf *active-context-installed-systems* installed-system-names
*active-context-visible-primary-system-names* visible-primary-system-names)))
(values source-registry installed-system-names visible-primary-system-names)))
*active-context-visible-primary-system-names* visible-system-names
*active-context-editable-primary-system-names* editable-system-names))
(values source-registry installed-system-names visible-system-names editable-system-names))))
......@@ -37,8 +37,8 @@
#:default-context
#:inside-bundle-exec-p
#:install
#:install-and-reload-context-config
#:install-without-dependencies-and-reload-context-config
#:install-and-reload-config
#:install-without-dependencies-and-reload-config
#:maybe-cleanup-clpm-client
#:missing-system
#:missing-system-name
......@@ -50,7 +50,9 @@
#:release-diff-old-source
#:release-diff-old-version
#:release-diff-project-name
#:reload-context-config))
#:reload-config
#:reresolve-requirements-and-reload-config
#:update))
(in-package #:clpm-client)
......
;;;; Interface to clpm update
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
(in-package #:clpm-client)
(defun update (&key projects
systems
(validate 'context-diff-approved-p)
(context (default-context))
(update-asdf-config (asdf-integration-active-p)))
"Update a set of projects and systems. Returns four values. The first is a
source registry form, the second is a list of systems installed in the context,
the third is a list of primary system names visible when that source registry
form is used, and the fourth is a list of primary system names that are editable
in the context.
PROJECTS and SYSTEMS must be lists of strings. If none are specified, every
project in the CONTEXT is eligible for upgrading.
VALIDATE must be a function of one argument (a diff) and returns non-NIL if the
install should proceed.
If UPDATE-ASDF-CONFIG is non-NIL and CONTEXT is the active context, then ASDF's
source registry is updated with the results."
(with-clpm-proc (proc)
(clpm-proc-print
proc
`(with-clpm-session ()
;; Use a symbol that we know is going to be present in the CLPM package.
,(if (context-bundle-p context)
`(bundle-update :projects ',(ensure-list projects)
:systems ',(ensure-list systems)
:clpmfile ,context
:validate ,(make-diff-validator-fun))
`(update :update-projects ',(ensure-list projects)
:update-systems ',(ensure-list systems)
:context ,context
:validate ,(make-diff-validator-fun)))
(list (source-registry :context ,context)
(installed-system-names :context ,context)
(visible-primary-system-names :context ,context)