Commit 1a5996d5 authored by Eric Timmons's avatar Eric Timmons
Browse files

Implement BUNDLE-EXEC using EXEC

parent 81bf9afc
......@@ -12,7 +12,7 @@
#:clpm/clpmfile
#:clpm/config
#:clpm/context
#:clpm/execvpe
#:clpm/exec
#:clpm/install
#:clpm/log
#:clpm/repos
......@@ -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)))
......@@ -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))
......@@ -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)
......@@ -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))))
......@@ -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)))
(*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))))
(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)))
(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))
......@@ -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
......
......@@ -26,29 +26,34 @@ 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-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))))))
(with-sources-using-installed-only ()
(with-context (context)
(let* ((context-name (context-name context))
(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
: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
(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))))
,(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))))))))
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