Commit 81bf9afc authored by Eric Timmons's avatar Eric Timmons
Browse files

Replace most GET-CONTEXTs with WITH-CONTEXT

This allows us to set dynamic vars based on the context
parent 34c3ec53
......@@ -19,28 +19,36 @@
(defun asd-pathnames (&key context)
(with-clpm-session ()
(context-asd-pathnames (get-context context))))
(with-context (context)
(context-asd-pathnames context))))
(defun find-system-asd-pathname (system-name &key context)
(with-clpm-session ()
(context-find-system-asd-pathname (get-context context) system-name)))
(with-context (context)
(context-find-system-asd-pathname context system-name))))
(defun installed-system-names (&key context)
(mapcar 'system-name (context-installed-systems (get-context context))))
(with-clpm-session ()
(with-context (context)
(mapcar 'system-name (context-installed-systems context)))))
(defun output-translations (&key context)
(with-clpm-session ()
(context-output-translations (get-context context))))
(with-context (context)
(context-output-translations context))))
(defun source-registry (&key context with-client-p
ignore-inherited-source-registry
splice-inherited)
(with-clpm-session ()
(context-to-asdf-source-registry-form
(get-context context)
:with-client with-client-p
:ignore-inherited ignore-inherited-source-registry
:splice-inherited splice-inherited)))
(with-context (context)
(context-to-asdf-source-registry-form
context
:with-client with-client-p
:ignore-inherited ignore-inherited-source-registry
:splice-inherited splice-inherited))))
(defun visible-primary-system-names (&key context)
(context-visible-primary-system-names (get-context context)))
(with-clpm-session ()
(with-context (context)
(context-visible-primary-system-names context))))
......@@ -37,11 +37,11 @@
#:context-visible-primary-system-names
#:context-write-asdf-files
#:copy-context
#:get-context
#:load-anonymous-context-from-pathname
#:load-global-context
#:save-context
#:serialize-context-to-stream))
#:serialize-context-to-stream
#:with-context))
(in-package #:clpm/context)
......@@ -125,6 +125,27 @@ can be named, global contexts, or anonymous."))
(context-vcs-source context)
(context-user-sources context)))
(defun make-vcs-override-fun (root-pathname)
(let ((root-pathname (uiop:pathname-directory-pathname root-pathname)))
(lambda (project-name)
(let ((override (config-value :bundle :local project-name)))
(when override
(merge-pathnames override root-pathname))))))
(defun call-with-context (thunk context-designator)
(let ((context (get-context context-designator)))
(if (context-anonymous-p context)
(let* ((*default-pathname-defaults* (uiop:pathname-directory-pathname (context-name context)))
(*vcs-project-override-fun* (make-vcs-override-fun *default-pathname-defaults*)))
(with-config-source (:pathname (merge-pathnames ".clpm/bundle.conf"
(uiop:pathname-directory-pathname
(context-name context))))
(funcall thunk context)))
(funcall thunk context))))
(defmacro with-context ((context-var &optional (context-value context-var)) &body body)
`(call-with-context (lambda (,context-var) ,@body) ,context-value))
;; * Adding requirements
......
......@@ -26,29 +26,29 @@ If WITH-CLIENT-P is non-NIL, the clpm-client system is available."
(unless (stringp command)
(error "COMMAND must be a string."))
(with-clpm-session ()
(let* ((context (get-context context))
(context-name (context-name context))
(ignore-inherited-source-registry
(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
:with-client with-client-p
:ignore-inherited ignore-inherited-source-registry
:splice-inherited splice-inherited))
(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 command args
`(("CL_SOURCE_REGISTRY" . ,(format nil "~S" source-registry))
,@(when output-translations
`(("ASDF_OUTPUT_TRANSLATIONS" . ,(format nil "~S" output-translations))))
("CLPM_EXEC_CONTEXT" . ,context-name)
("CLPM_EXEC_INSTALLED_SYSTEMS" . ,(format nil "~S" installed-system-names))
("CLPM_EXEC_VISIBLE_PRIMARY_SYSTEMS" . ,(format nil "~S" visible-primary-system-names))
,@(when ignore-inherited-source-registry
'(("CLPM_EXEC_IGNORE_INHERITED_SOURCE_REGISTRY" . "t")))
,@(when (and (not ignore-inherited-source-registry) splice-inherited)
`(("CLPM_EXEC_SPLICE_INHERITED_SOURCE_REGISTRY" . ,splice-inherited))))
t)))))
(with-context (context)
(let* ((context-name (context-name context))
(ignore-inherited-source-registry
(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
:with-client with-client-p
:ignore-inherited ignore-inherited-source-registry
:splice-inherited splice-inherited))
(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 command args
`(("CL_SOURCE_REGISTRY" . ,(format nil "~S" source-registry))
,@(when output-translations
`(("ASDF_OUTPUT_TRANSLATIONS" . ,(format nil "~S" output-translations))))
("CLPM_EXEC_CONTEXT" . ,context-name)
("CLPM_EXEC_INSTALLED_SYSTEMS" . ,(format nil "~S" installed-system-names))
("CLPM_EXEC_VISIBLE_PRIMARY_SYSTEMS" . ,(format nil "~S" visible-primary-system-names))
,@(when ignore-inherited-source-registry
'(("CLPM_EXEC_IGNORE_INHERITED_SOURCE_REGISTRY" . "t")))
,@(when (and (not ignore-inherited-source-registry) splice-inherited)
`(("CLPM_EXEC_SPLICE_INHERITED_SOURCE_REGISTRY" . ,splice-inherited))))
t))))))
......@@ -99,39 +99,39 @@ 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 ()
(let ((context (get-context context))
(reqs (append (mapcar (rcurry #'make-requirement
:project
:version version :source source :ref ref :no-deps-p no-deps-p)
projects)
(mapcar (rcurry #'make-requirement
:system
:version version :source source :ref ref :no-deps-p no-deps-p)
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))))
(with-context (context)
(let ((reqs (append (mapcar (rcurry #'make-requirement
:project
:version version :source source :ref ref :no-deps-p no-deps-p)
projects)
(mapcar (rcurry #'make-requirement
:system
:version version :source source :ref ref :no-deps-p no-deps-p)
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
context
(validate (constantly t))
save-context-p
update-projects)
(let* ((orig-context (get-context context))
(new-context (copy-context orig-context)))
(dolist (r reqs)
(context-add-requirement! new-context r))
(setf new-context (resolve-requirements new-context :update-projects update-projects))
(let ((result (funcall validate (make-context-diff orig-context new-context))))
(if result
(progn
(mapc #'install-release (context-releases new-context))
(when save-context-p
(context-write-asdf-files new-context)
(save-context new-context))
new-context)
orig-context))))
(with-context (orig-context context)
(with-context (new-context (copy-context orig-context))
(dolist (r reqs)
(context-add-requirement! new-context r))
(setf new-context (resolve-requirements new-context :update-projects update-projects))
(let ((result (funcall validate (make-context-diff orig-context new-context))))
(if result
(progn
(mapc #'install-release (context-releases new-context))
(when save-context-p
(context-write-asdf-files new-context)
(save-context new-context))
new-context)
orig-context)))))
......@@ -23,21 +23,21 @@
(validate (constantly t))
context)
(with-clpm-session ()
(let* ((orig-context (get-context context))
(context (copy-context orig-context)))
;; Map all systems to their corresponding projects.
(dolist (system update-systems)
(when-let* ((system-release (find system (context-system-releases orig-context)
:key (compose #'system-name #'system-release-system)
:test #'equal))
(release (system-release-release system-release))
(project-name (project-name (release-project release))))
(pushnew project-name update-projects :test #'equal)))
(with-context (orig-context context)
(with-context (context (copy-context orig-context))
;; Map all systems to their corresponding projects.
(dolist (system update-systems)
(when-let* ((system-release (find system (context-system-releases orig-context)
:key (compose #'system-name #'system-release-system)
:test #'equal))
(release (system-release-release system-release))
(project-name (project-name (release-project release))))
(pushnew project-name update-projects :test #'equal)))
(log:info "Updating ~:[all~;~:*~{~A~^, ~}~] projects." update-projects)
(let* ((new-context (resolve-requirements context :update-projects (or update-projects t)))
(diff (make-context-diff orig-context new-context)))
(when (funcall validate diff)
(mapc #'install-release (context-releases new-context))
(context-write-asdf-files new-context)
(save-context new-context))))))
(log:info "Updating ~:[all~;~:*~{~A~^, ~}~] projects." update-projects)
(let* ((new-context (resolve-requirements context :update-projects (or update-projects t)))
(diff (make-context-diff orig-context new-context)))
(when (funcall validate diff)
(mapc #'install-release (context-releases new-context))
(context-write-asdf-files new-context)
(save-context new-context)))))))
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