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

Implement BUNDLE-EXEC using EXEC

parent 81bf9afc
Loading
Loading
Loading
Loading
+3 −24
Original line number Diff line number Diff line
@@ -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)))
+35 −12
Original line number Diff line number Diff line
@@ -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)))
  (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))
@@ -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
+31 −26
Original line number Diff line number Diff line
@@ -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
@@ -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))))))))