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
Loading
Loading
Loading
Loading
+18 −10
Original line number Diff line number Diff line
@@ -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 ()
    (with-context (context)
      (context-to-asdf-source-registry-form
     (get-context context)
       context
       :with-client with-client-p
       :ignore-inherited ignore-inherited-source-registry
     :splice-inherited splice-inherited)))
       :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))))
+23 −2
Original line number Diff line number Diff line
@@ -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 −26
Original line number Diff line number Diff line
@@ -26,8 +26,8 @@ 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))
    (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"))
@@ -51,4 +51,4 @@ If WITH-CLIENT-P is non-NIL, the clpm-client system is available."
                         '(("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)))))
                   t))))))
+30 −30
Original line number Diff line number Diff line
@@ -99,8 +99,8 @@ 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
    (with-context (context)
      (let ((reqs (append (mapcar (rcurry #'make-requirement
                                          :project
                                          :version version :source source :ref ref :no-deps-p no-deps-p)
                                  projects)
@@ -114,15 +114,15 @@ install should proceed."
                                                   :why t
                                                   :no-deps-p no-deps-p))
                                  asds))))
      (install-requirements reqs :context context :validate validate :save-context-p save-context-p))))
        (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)))
  (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))
@@ -134,4 +134,4 @@ install should proceed."
                (context-write-asdf-files new-context)
                (save-context new-context))
              new-context)
          orig-context))))
            orig-context)))))
+17 −17
Original line number Diff line number Diff line
@@ -23,8 +23,8 @@
                 (validate (constantly t))
                 context)
  (with-clpm-session ()
    (let* ((orig-context (get-context context))
           (context (copy-context orig-context)))
    (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)
@@ -40,4 +40,4 @@
          (when (funcall validate diff)
            (mapc #'install-release (context-releases new-context))
            (context-write-asdf-files new-context)
          (save-context new-context))))))
            (save-context new-context)))))))