Loading clpm/bundle.lisp +3 −24 Original line number Diff line number Diff line Loading @@ -12,7 +12,7 @@ #:clpm/clpmfile #:clpm/config #:clpm/context #:clpm/execvpe #:clpm/exec #:clpm/install #:clpm/log #:clpm/repos Loading Loading @@ -171,26 +171,5 @@ COMMAND must be a string naming the command to run. ARGS must be a list of strings containing the arguments to pass to the command. If WITH-CLIENT-P is non-NIL, the clpm-client system is available." (unless (stringp command) (error "COMMAND must be a string.")) (with-bundle-session (clpmfile) (with-sources-using-installed-only () (let* ((clpmfile-pathname (clpmfile-pathname clpmfile)) (lockfile-pathname (clpmfile-lockfile-pathname clpmfile)) (lockfile (load-lockfile lockfile-pathname)) (cl-source-registry-form (context-to-asdf-source-registry-form lockfile :with-client with-client-p :ignore-inherited t)) (output-translations (context-output-translations lockfile)) (installed-system-names (sort (mapcar #'system-name (context-installed-systems lockfile)) #'string<)) (visible-primary-system-names (sort (context-visible-primary-system-names lockfile) #'string<))) (with-standard-io-syntax (execvpe command args `(("CL_SOURCE_REGISTRY" . ,(format nil "~S" cl-source-registry-form)) ,@(when output-translations `(("ASDF_OUTPUT_TRANSLATIONS" . ,(format nil "~S" output-translations)))) ("CLPM_EXEC_INSTALLED_SYSTEMS" . ,(format nil "~S" installed-system-names)) ("CLPM_EXEC_VISIBLE_PRIMARY_SYSTEMS" . ,(format nil "~S" visible-primary-system-names)) ("CLPM_EXEC_CLPMFILE" . ,(uiop:native-namestring clpmfile-pathname)) ("CLPM_EXEC_IGNORE_INHERITED_SOURCE_REGISTRY" . "t")) t)))))) (exec command args :with-client-p with-client-p :context (clpmfile-pathname clpmfile))) clpm/context.lisp +35 −12 Original line number Diff line number Diff line Loading @@ -38,7 +38,6 @@ #:context-write-asdf-files #:copy-context #:load-anonymous-context-from-pathname #:load-global-context #:save-context #:serialize-context-to-stream #:with-context)) Loading Loading @@ -94,9 +93,31 @@ can be named, global contexts, or anonymous.")) (setf (context-vcs-source context) (make-source 'vcs-source :name :implicit-vcs))) (defun context-anonymous-p (context) (defgeneric context-name (context)) (defmethod context-name ((context pathname)) context) (defmethod context-name ((context string)) context) (defmethod context-name ((context (eql nil))) (config-value :context)) (defgeneric context-anonymous-p (context)) (defmethod context-anonymous-p ((context context)) (pathnamep (context-name context))) (defmethod context-anonymous-p ((context pathname)) t) (defmethod context-anonymous-p ((context string)) nil) (defmethod context-anonymous-p ((context (eql nil))) nil) (defun copy-context (context) (make-instance 'context :name (context-name context) Loading @@ -117,6 +138,9 @@ can be named, global contexts, or anonymous.")) (load-global-context context-designator nil)) ((null context-designator) (load-global-context (config-value :context) nil)) ((pathnamep context-designator) (load-anonymous-context-from-pathname (merge-pathnames (make-pathname :type "lock") context-designator))) (t (error "Unable to translate ~S to a context object" context-designator)))) Loading @@ -133,15 +157,14 @@ can be named, global contexts, or anonymous.")) (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))) (if (context-anonymous-p context-designator) (let* ((context-name context-designator) (*default-pathname-defaults* (uiop:pathname-directory-pathname context-name)) (*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)))) (uiop:pathname-directory-pathname context-name))) (funcall thunk (get-context context-designator)))) (funcall thunk (get-context context-designator)))) (defmacro with-context ((context-var &optional (context-value context-var)) &body body) `(call-with-context (lambda (,context-var) ,@body) ,context-value)) Loading Loading @@ -441,7 +464,7 @@ in place with the same name. Return the new requirement if it was modified." (defun save-context (context) (assert (context-reverse-dependencies context)) (let ((pn (if (context-anonymous-p context) (context-name context) (merge-pathnames (make-pathname :type "lock") (context-name context)) (global-context-pathname (context-name context))))) (ensure-directories-exist pn) (with-open-file (s pn Loading clpm/exec.lisp +31 −26 Original line number Diff line number Diff line Loading @@ -26,10 +26,12 @@ 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 () (with-sources-using-installed-only () (with-context (context) (let* ((context-name (context-name context)) (ignore-inherited-source-registry (config-value :contexts context-name :ignore-inherited-source-registry)) (or (context-anonymous-p context) (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 Loading @@ -40,15 +42,18 @@ If WITH-CLIENT-P is non-NIL, the clpm-client system is available." (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 (let ((*print-case* :downcase)) (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) ,(if (context-anonymous-p context) `("CLPM_EXEC_CLPMFILE" . ,(uiop:native-namestring context-name)) `("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)))))) t)))))))) Loading
clpm/bundle.lisp +3 −24 Original line number Diff line number Diff line Loading @@ -12,7 +12,7 @@ #:clpm/clpmfile #:clpm/config #:clpm/context #:clpm/execvpe #:clpm/exec #:clpm/install #:clpm/log #:clpm/repos Loading Loading @@ -171,26 +171,5 @@ COMMAND must be a string naming the command to run. ARGS must be a list of strings containing the arguments to pass to the command. If WITH-CLIENT-P is non-NIL, the clpm-client system is available." (unless (stringp command) (error "COMMAND must be a string.")) (with-bundle-session (clpmfile) (with-sources-using-installed-only () (let* ((clpmfile-pathname (clpmfile-pathname clpmfile)) (lockfile-pathname (clpmfile-lockfile-pathname clpmfile)) (lockfile (load-lockfile lockfile-pathname)) (cl-source-registry-form (context-to-asdf-source-registry-form lockfile :with-client with-client-p :ignore-inherited t)) (output-translations (context-output-translations lockfile)) (installed-system-names (sort (mapcar #'system-name (context-installed-systems lockfile)) #'string<)) (visible-primary-system-names (sort (context-visible-primary-system-names lockfile) #'string<))) (with-standard-io-syntax (execvpe command args `(("CL_SOURCE_REGISTRY" . ,(format nil "~S" cl-source-registry-form)) ,@(when output-translations `(("ASDF_OUTPUT_TRANSLATIONS" . ,(format nil "~S" output-translations)))) ("CLPM_EXEC_INSTALLED_SYSTEMS" . ,(format nil "~S" installed-system-names)) ("CLPM_EXEC_VISIBLE_PRIMARY_SYSTEMS" . ,(format nil "~S" visible-primary-system-names)) ("CLPM_EXEC_CLPMFILE" . ,(uiop:native-namestring clpmfile-pathname)) ("CLPM_EXEC_IGNORE_INHERITED_SOURCE_REGISTRY" . "t")) t)))))) (exec command args :with-client-p with-client-p :context (clpmfile-pathname clpmfile)))
clpm/context.lisp +35 −12 Original line number Diff line number Diff line Loading @@ -38,7 +38,6 @@ #:context-write-asdf-files #:copy-context #:load-anonymous-context-from-pathname #:load-global-context #:save-context #:serialize-context-to-stream #:with-context)) Loading Loading @@ -94,9 +93,31 @@ can be named, global contexts, or anonymous.")) (setf (context-vcs-source context) (make-source 'vcs-source :name :implicit-vcs))) (defun context-anonymous-p (context) (defgeneric context-name (context)) (defmethod context-name ((context pathname)) context) (defmethod context-name ((context string)) context) (defmethod context-name ((context (eql nil))) (config-value :context)) (defgeneric context-anonymous-p (context)) (defmethod context-anonymous-p ((context context)) (pathnamep (context-name context))) (defmethod context-anonymous-p ((context pathname)) t) (defmethod context-anonymous-p ((context string)) nil) (defmethod context-anonymous-p ((context (eql nil))) nil) (defun copy-context (context) (make-instance 'context :name (context-name context) Loading @@ -117,6 +138,9 @@ can be named, global contexts, or anonymous.")) (load-global-context context-designator nil)) ((null context-designator) (load-global-context (config-value :context) nil)) ((pathnamep context-designator) (load-anonymous-context-from-pathname (merge-pathnames (make-pathname :type "lock") context-designator))) (t (error "Unable to translate ~S to a context object" context-designator)))) Loading @@ -133,15 +157,14 @@ can be named, global contexts, or anonymous.")) (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))) (if (context-anonymous-p context-designator) (let* ((context-name context-designator) (*default-pathname-defaults* (uiop:pathname-directory-pathname context-name)) (*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)))) (uiop:pathname-directory-pathname context-name))) (funcall thunk (get-context context-designator)))) (funcall thunk (get-context context-designator)))) (defmacro with-context ((context-var &optional (context-value context-var)) &body body) `(call-with-context (lambda (,context-var) ,@body) ,context-value)) Loading Loading @@ -441,7 +464,7 @@ in place with the same name. Return the new requirement if it was modified." (defun save-context (context) (assert (context-reverse-dependencies context)) (let ((pn (if (context-anonymous-p context) (context-name context) (merge-pathnames (make-pathname :type "lock") (context-name context)) (global-context-pathname (context-name context))))) (ensure-directories-exist pn) (with-open-file (s pn Loading
clpm/exec.lisp +31 −26 Original line number Diff line number Diff line Loading @@ -26,10 +26,12 @@ 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 () (with-sources-using-installed-only () (with-context (context) (let* ((context-name (context-name context)) (ignore-inherited-source-registry (config-value :contexts context-name :ignore-inherited-source-registry)) (or (context-anonymous-p context) (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 Loading @@ -40,15 +42,18 @@ If WITH-CLIENT-P is non-NIL, the clpm-client system is available." (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 (let ((*print-case* :downcase)) (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) ,(if (context-anonymous-p context) `("CLPM_EXEC_CLPMFILE" . ,(uiop:native-namestring context-name)) `("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)))))) t))))))))