Commit 22d69ec1 authored by Eric Timmons's avatar Eric Timmons
Browse files

cli less work: bundle exec

parent fae748aa
......@@ -5,23 +5,14 @@
(uiop:define-package #:clpm-cli/commands/bundle/exec
(:use #:cl
#:clpm/bundle
#:clpm-cli/commands/bundle/common
#:clpm-cli/common-args
#:clpm-cli/interface-defs
#:clpm/clpmfile
#:clpm/config
#:clpm/context
#:clpm/execvpe
#:clpm/log
#:clpm/source
#:clpm/utils)
(:import-from #:adopt))
#:clpm-cli/interface-defs)
(:import-from #:adopt)
(:import-from #:clpm))
(in-package #:clpm-cli/commands/bundle/exec)
(setup-logger)
(defparameter *option-with-client*
(adopt:make-option
:bundle-exec-with-client
......@@ -40,32 +31,5 @@
*option-with-client*)))
(define-cli-command (("bundle" "exec") *bundle-exec-ui*) (args options)
(let* ((clpmfile-pathname (bundle-clpmfile-pathname))
(clpmfile (get-clpmfile clpmfile-pathname))
(lockfile-pathname (clpmfile-lockfile-pathname clpmfile))
(include-client-p (gethash :bundle-exec-with-client options))
(cl-source-registry-form (bundle-source-registry clpmfile-pathname
:include-client-p include-client-p))
(output-translations-form (bundle-output-translations clpmfile-pathname))
(lockfile (bundle-context clpmfile))
(installed-system-names (sort (mapcar #'system-name (context-installed-systems lockfile)) #'string<))
(visible-primary-system-names (sort (context-visible-primary-system-names lockfile) #'string<))
(command args))
(log:debug "Computed CL_SOURCE_REGISTRY:~%~S" cl-source-registry-form)
(with-standard-io-syntax
(execvpe (first command) (rest command)
`(("CL_SOURCE_REGISTRY" . ,(prin1-to-string cl-source-registry-form))
,@(when output-translations-form
`(("ASDF_OUTPUT_TRANSLATIONS" . ,(prin1-to-string output-translations-form))))
,@(if *live-script-location*
`(("CLPM_BUNDLE_BIN_LIVE_SCRIPT" . ,(uiop:native-namestring *live-script-location*))
("CLPM_BUNDLE_BIN_LISP_IMPLEMENTATION" . ,(lisp-implementation-type)))
`(("CLPM_BUNDLE_BIN" . ,(uiop:argv0))))
("CLPM_BUNDLE_INSTALLED_SYSTEMS" . ,(format nil "~{~A~^ ~}" installed-system-names))
("CLPM_BUNDLE_VISIBLE_PRIMARY_SYSTEMS" . ,(format nil "~{~A~^ ~}" visible-primary-system-names))
("CLPM_BUNDLE_CLPMFILE" . ,(uiop:native-namestring clpmfile-pathname))
("CLPM_BUNDLE_CLPMFILE_LOCK" . ,(uiop:native-namestring lockfile-pathname)))
t))
;; We got here, there is some .asd file not present. Tell the user!
;; (format *error-output* "The following system files are missing! Please run `clpm bundle install` and try again!~%~A" missing-pathnames)
nil))
(clpm:bundle-exec (first args) (rest args) :with-client-p (gethash :bundle-exec-with-client options))
nil)
......@@ -12,6 +12,7 @@
#:clpm/clpmfile
#:clpm/config
#:clpm/context
#:clpm/execvpe
#:clpm/install
#:clpm/log
#:clpm/repos
......@@ -21,6 +22,7 @@
#:do-urlencode)
(:export #:bundle-clpmfile-pathname
#:bundle-context
#:bundle-exec
#:bundle-init
#:bundle-install
#:bundle-output-translations
......@@ -33,6 +35,18 @@
(setup-logger)
(defun call-with-bundle-session (thunk &key clpmfile)
(with-clpm-session ()
(with-config-source (:pathname (merge-pathnames ".clpm/bundle.conf"
(uiop:pathname-directory-pathname
(clpmfile-pathname clpmfile))))
(let ((*default-pathname-defaults* (uiop:pathname-directory-pathname (clpmfile-pathname clpmfile)))
(*vcs-project-override-fun* (make-vcs-override-fun (clpmfile-pathname clpmfile))))
(funcall thunk)))))
(defmacro with-bundle-session ((clpmfile) &body body)
`(call-with-bundle-session (lambda () ,@body) :clpmfile ,clpmfile))
(defun bundle-clpmfile-pathname ()
(merge-pathnames (config-value :bundle :clpmfile)
(uiop:getcwd)))
......@@ -204,3 +218,36 @@ the lock file if necessary."
:update-projects (or update-projects t)))
(when changedp
(save-context lockfile))))
(defun bundle-exec (command args &key clpmfile
with-client-p)
"exec(3) (or approximate if system doesn't have exec) a COMMAND in bundle's context
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* ((*fetch-repo-automatically* nil)
(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))
(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_BUNDLE_CLPMFILE" . ,(uiop:native-namestring clpmfile-pathname))
("CLPM_BUNLDE_CLPMFILE_LOCK" . ,(uiop:native-namestring lockfile-pathname)))
t))))))
......@@ -18,6 +18,8 @@
#:clpm/sync
#:clpm/update
#:clpm/version)
;; From bundle
(:export #:bundle-exec)
;; From client
(:export #:client-asd-pathname)
;; From config
......
......@@ -21,12 +21,23 @@
(in-package #:clpm/clpmfile)
;; * Class Definitions
(defun clpmfile-pathname (clpmfile)
(defgeneric clpmfile-pathname (clpmfile))
(defmethod clpmfile-pathname ((clpmfile context))
(assert (context-anonymous-p clpmfile))
(context-name clpmfile))
(defmethod clpmfile-pathname ((clpmfile pathname))
clpmfile)
(defmethod clpmfile-pathname ((clpmfile string))
clpmfile)
(defmethod clpmfile-pathname ((clpmfile (eql nil)))
(merge-pathnames (config-value :bundle :clpmfile)
(uiop:getcwd)))
(defun clpmfile-lockfile-pathname (clpmfile)
(merge-pathnames (make-pathname :type "lock")
(clpmfile-pathname clpmfile)))
......
......@@ -80,7 +80,7 @@ rebind *CONFIG-SOURCES* with CONFIG-SOURCE placed in the appropriate position
and then call THUNK."
(assert (xor config-source pathname options-ht))
(when pathname
(setf config-source (list 'config-file-source :pathname pathname)))
(setf config-source (list 'config-file-source :pathname (pathname pathname))))
(when options-ht
(setf config-source (list 'config-cli-source :arg-ht options-ht)))
(if (member config-source *config-sources* :test #'equal)
......
......@@ -14,7 +14,8 @@
#:clpm/data
#:clpm/log
#:clpm/requirement
#:clpm/source)
#:clpm/source
#:do-urlencode)
(:export #:context
#:context-add-requirement!
#:context-anonymous-p
......@@ -270,16 +271,32 @@ in place with the same name. Return the new requirement if it was modified."
(terpri s)))))))))
(defun context-output-translations (context)
(assert (not (context-anonymous-p context)))
(let* ((context (get-context context))
(name (context-name context))
(config-value (config-value :contexts name :output-translation)))
(when config-value
`(:output-translations
:ignore-inherited-configuration
(t (:root ,@(rest (pathname-directory (clpm-cache-pathname `("contexts" ,name "fasl-cache")
:ensure-directory t)))
:implementation :**/ :*.*.*))))))
(if (context-anonymous-p context)
(let ((pathname (context-name context)))
(case (config-value :bundle :output-translation)
((t)
`(:output-translations
:ignore-inherited-configuration
(t (:root ,@(rest (pathname-directory (clpm-cache-pathname '("bundle" "fasl-cache")
:ensure-directory t)))
,(urlencode (format nil "~{~A~^/~}" (rest (pathname-directory pathname))))
:implementation :** :*.*.*))))
(:local
`(:output-translations
:ignore-inherited-configuration
(t (,(uiop:pathname-directory-pathname pathname) ".clpm" "fasl-cache"
:implementation :**/ :*.*.*))))
(t
nil)))
(let* ((context (get-context context))
(name (context-name context))
(config-value (config-value :contexts name :output-translation)))
(when config-value
`(:output-translations
:ignore-inherited-configuration
(t (:root ,@(rest (pathname-directory (clpm-cache-pathname `("contexts" ,name "fasl-cache")
:ensure-directory t)))
:implementation :**/ :*.*.*)))))))
;; * Deserializing
......
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