Commit 01697ef4 authored by Eric Timmons's avatar Eric Timmons
Browse files

Client: seed the installed systems from chosen context

parent 26ee45d9
......@@ -33,7 +33,7 @@ prompting.
+ NIL :: Do nothing.")
(defvar *clpm-installed-systems* (make-hash-table :test 'equal)
(defvar *clpm-installed-systems* nil
"A cache to hold a mapping from primary system names to .asd pathnames for
systems installed by CLPM during this session. Used because there doesn't seem
to be an exposed, stable way to update ASDF's source registry once we install a
......@@ -61,6 +61,16 @@ new system.")
(setf (gethash (pathname-name p) *clpm-installed-systems*)
(pathname p)))))
(defun populate-installed-systems ()
(setf *clpm-installed-systems* (make-hash-table :test 'equal))
(let ((pathnames (ignore-errors
(run-clpm `("context" "pathnames" "--output=sexp" ,*clpm-context*)
:output '(:string :stripped t)))))
(when pathnames
(dolist (p (uiop:with-safe-io-syntax () (read-from-string pathnames)))
(setf (gethash (pathname-name p) *clpm-installed-systems*)
(pathname p))))))
(defun clpm-system-search (system-name)
"A search function for ASDF's *SYSTEM-DEFINITION-SEARCH-FUNCTIONS* list.
......@@ -68,6 +78,10 @@ Given a system name, it tries to find it using the CLPM executable (see:
*CLPM-EXECUTABLE*). If the system cannot be found, it either does nothing,
signals a condition, and/or installs the system with CLPM-INSTALL-SYSTEM (see:
*CLPM-SYSTEM-NOT-FOUND-BEHAVIOR*)."
;; If this is the first time we've called this, try to seed the installed
;; systems hash table first.
(unless *clpm-installed-systems*
(populate-installed-systems))
(let ((primary-name (asdf:primary-system-name system-name)))
(unless (or (equal "asdf" primary-name)
(equal "uiop" primary-name))
......
......@@ -12,6 +12,7 @@
#:clpm-client/cleanup
#:clpm-client/clpm)
(:export #:*clpm-cleanup-on-dump-p*
#:*clpm-context*
#:*clpm-executable*
#:*clpm-system-not-found-behavior*
#:activate-clpm
......
......@@ -35,9 +35,10 @@ change this to be an absolute path to the executable.")
(defun compute-clpm-executable ()
"If we're running inside a bundle exec environment, try to use the same clpm
executable that spawned us."
(setf *clpm-executable*
(or (uiop:getenv "CLPM_BUNDLE_BIN_PATH")
"clpm")))
(or *clpm-executable*
(setf *clpm-executable*
(or (uiop:getenv "CLPM_BUNDLE_BIN_PATH")
"clpm"))))
(uiop:register-image-restore-hook 'compute-clpm-executable)
......
;;;; Context command definitions
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:clpm/cli/context
(:use #:cl
#:clpm/cli/context/common
#:clpm/cli/context/pathnames))
(in-package #:clpm/cli/context)
;;;; Common context CLI functions
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:clpm/cli/context/common
(:use #:cl
#:alexandria
#:clpm/cli/common-args
#:clpm/cli/subcommands)
(:import-from #:adopt)
(:import-from #:cl-ppcre))
(in-package #:clpm/cli/context/common)
(defparameter *default-ui*
(adopt:make-interface
:name "clpm context"
:summary "Common Lisp Package Manager Context"
:usage "context [options] subcommand"
:help "Context commands"
:contents (list *group-common*)))
(define-cli-command-folder
(("context") *default-ui*)
(args options)
(declare (ignore args options)))
;;;; clpm context pathnames
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:clpm/cli/context/pathnames
(:use #:cl
#:alexandria
#:clpm/context
#:clpm/cli/context/common
#:clpm/cli/common-args
#:clpm/cli/subcommands)
(:import-from #:adopt))
(in-package #:clpm/cli/context/pathnames)
(defparameter *context-pathnames-ui*
(adopt:make-interface
:name "clpm context pathnames"
:summary "Common Lisp Package Manager Context Pathnames"
:usage "context pathnames [options] CONTEXT-NAME"
:help "List the pathnames to all ASD files in the context"
:contents (list *group-common*
*option-output*)))
(define-cli-command (("context" "pathnames") *context-pathnames-ui*) (args options)
(assert (length= 1 args))
(let* ((context (get-context (first args)))
(context-pathnames (context-asd-pathnames context)))
(eswitch ((gethash :output options) :test 'equal)
(nil
(format t "~{~A~^~%~}" context-pathnames))
("sexp"
(uiop:with-safe-io-syntax ()
(prin1 context-pathnames)
(terpri))))
t))
......@@ -79,6 +79,10 @@
ht)
(sort out #'string<)))
(defun parse-options-ignoring-unrecognized (ui)
(handler-bind ((adopt:unrecognized-option #'adopt:discard-option))
(adopt:parse-options ui)))
(defun dispatch-subcommand (working-ht arguments options ui)
(let* ((subcommand-name (first arguments))
(dir-or-fun (gethash subcommand-name working-ht)))
......@@ -93,7 +97,7 @@
(gethash :ui dir-or-fun)
(when thunk
(multiple-value-bind (sub-args sub-options)
(adopt:parse-options default-ui)
(parse-options-ignoring-unrecognized default-ui)
(funcall thunk sub-args sub-options)))
(dispatch-subcommand dir-or-fun (rest arguments) options default-ui)))
((gethash :help options)
......
......@@ -8,6 +8,7 @@
#:clpm/cli/bundle
;;#:clpm/cli/client
;;#:clpm/cli/config
#:clpm/cli/context
#:clpm/cli/entry
#:clpm/cli/install
#:clpm/cli/license-info
......
Supports Markdown
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