Loading clpm/context-queries.lisp +18 −10 Original line number Diff line number Diff line Loading @@ -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)))) clpm/context.lisp +23 −2 Original line number Diff line number Diff line Loading @@ -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) Loading Loading @@ -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 Loading clpm/exec.lisp +26 −26 Original line number Diff line number Diff line Loading @@ -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")) Loading @@ -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)))))) clpm/install.lisp +30 −30 Original line number Diff line number Diff line Loading @@ -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) Loading @@ -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)) Loading @@ -134,4 +134,4 @@ install should proceed." (context-write-asdf-files new-context) (save-context new-context)) new-context) orig-context)))) orig-context))))) clpm/update.lisp +17 −17 Original line number Diff line number Diff line Loading @@ -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) Loading @@ -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))))))) Loading
clpm/context-queries.lisp +18 −10 Original line number Diff line number Diff line Loading @@ -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))))
clpm/context.lisp +23 −2 Original line number Diff line number Diff line Loading @@ -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) Loading Loading @@ -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 Loading
clpm/exec.lisp +26 −26 Original line number Diff line number Diff line Loading @@ -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")) Loading @@ -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))))))
clpm/install.lisp +30 −30 Original line number Diff line number Diff line Loading @@ -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) Loading @@ -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)) Loading @@ -134,4 +134,4 @@ install should proceed." (context-write-asdf-files new-context) (save-context new-context)) new-context) orig-context)))) orig-context)))))
clpm/update.lisp +17 −17 Original line number Diff line number Diff line Loading @@ -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) Loading @@ -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)))))))