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

cli less work: bundle exec

parent fae748aa

cli/commands/bundle/exec.lisp

+5 −41
Original line number Diff line number Diff line
@@ -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)

clpm/bundle.lisp

+47 −0
Original line number Diff line number Diff line
@@ -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))))))

clpm/clpm.lisp

+2 −0
Original line number Diff line number Diff line
@@ -18,6 +18,8 @@ 
        #:clpm/sync

        #:clpm/update

        #:clpm/version)

  ;; From bundle

  (:export #:bundle-exec)

  ;; From client

  (:export #:client-asd-pathname)

  ;; From config

clpm/clpmfile.lisp

+13 −2
Original line number Diff line number Diff line
@@ -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)))

clpm/config.lisp

+1 −1
Original line number Diff line number Diff line
@@ -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)