Loading client/asdf.lisp +44 −37 Original line number Diff line number Diff line Loading @@ -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 Loading @@ -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)))) Loading Loading @@ -91,13 +99,17 @@ recursion." (asdf:initialize-source-registry source-registry)) (defun handle-missing-system (system-name active-context) (flet ((%install (no-deps) (labels ((%do-install (systems no-deps) (let ((new-source-registry (install :systems (unless (context-bundle-p active-context) (list system-name)) (install :systems systems :no-deps no-deps :update-asdf-config t))) (when new-source-registry (find-system-without-clpm system-name))))) (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)) Loading @@ -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 Loading @@ -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, Loading @@ -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)))) Loading client/bundle.lisp +1 −63 Original line number Diff line number Diff line Loading @@ -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)))) client/clpm-client.asd +1 −0 Original line number Diff line number Diff line Loading @@ -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")))) client/context.lisp +53 −62 Original line number Diff line number Diff line Loading @@ -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.") Loading @@ -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) Loading @@ -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 Loading @@ -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 Loading client/diff.lisp +2 −37 Original line number Diff line number Diff line Loading @@ -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 Loading Loading
client/asdf.lisp +44 −37 Original line number Diff line number Diff line Loading @@ -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 Loading @@ -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)))) Loading Loading @@ -91,13 +99,17 @@ recursion." (asdf:initialize-source-registry source-registry)) (defun handle-missing-system (system-name active-context) (flet ((%install (no-deps) (labels ((%do-install (systems no-deps) (let ((new-source-registry (install :systems (unless (context-bundle-p active-context) (list system-name)) (install :systems systems :no-deps no-deps :update-asdf-config t))) (when new-source-registry (find-system-without-clpm system-name))))) (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)) Loading @@ -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 Loading @@ -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, Loading @@ -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)))) Loading
client/bundle.lisp +1 −63 Original line number Diff line number Diff line Loading @@ -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))))
client/clpm-client.asd +1 −0 Original line number Diff line number Diff line Loading @@ -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"))))
client/context.lisp +53 −62 Original line number Diff line number Diff line Loading @@ -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.") Loading @@ -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) Loading @@ -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 Loading @@ -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 Loading
client/diff.lisp +2 −37 Original line number Diff line number Diff line Loading @@ -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 Loading