Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
clpm
clpm
Commits
015c8ab9
Commit
015c8ab9
authored
Feb 20, 2020
by
Eric Timmons
Browse files
Update client for full bundle and new feature support
parent
7a6a15e2
Changes
11
Hide whitespace changes
Inline
Side-by-side
src/clpm-client/asdf.lisp
View file @
015c8ab9
...
...
@@ -8,15 +8,20 @@
#:clpm-client/bundle
#:clpm-client/cleanup
#:clpm-client/clpm
#:clpm-client/context
#:clpm-client/install
)
(
:import-from
#:asdf
#:*system-definition-search-functions*
)
(
:export
#:*clpm-system-not-found-behavior*
#:activate-clpm
#:clpm-active-p
#:activate-clpm
-asdf-integration
#:clpm-
asdf-integration-
active-p
#:clpm-missing-system
#:clpm-system-search
#:deactivate-clpm
))
#:deactivate-clpm-asdf-integration
#:install-and-reload-bundle
#:install-system
#:install-system-and-dependencies
#:reload-bundle
))
(
in-package
#:clpm-client/asdf
)
...
...
@@ -33,12 +38,6 @@ prompting.
+ NIL :: Do nothing."
)
(
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
new system."
)
(
define-condition
clpm-missing-system
(
error
)
((
system-name
:initarg
:system-name
))
...
...
@@ -47,29 +46,96 @@ new system.")
(
slot-value
c
'system-name
))))
(
:documentation
"A condition signaled when a system is not installed."
))
(
defmacro
maybe-restart-case
(
condition
form
&rest
cases
)
`
(
if
,
condition
(
restart-case
,
form
,@
cases
)
,
form
))
(
defun
install-system-and-record-pathnames
(
system-name
&key
no-deps-p
)
(
let
((
pathnames
(
ignore-errors
(
clpm-install-system
system-name
:no-deps-p
no-deps-p
))))
(
dolist
(
p
pathnames
)
(
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
))))))
(
define-condition
clpm-bundle-install-diff
()
((
diff
:initarg
:diff
))
(
:report
(
lambda
(
c
s
)
(
format
s
"Bundle install would perform the following changes:~%~S"
(
slot-value
c
'diff
))))
(
:documentation
"A condition signaled when bundle install produces a diff."
))
(
defun
signal-missing-system
(
system-name
)
(
error
'clpm-missing-system
:system-name
system-name
))
(
defun
find-system-without-clpm
(
system-name
)
(
let
((
*clpm-system-not-found-behavior*
nil
))
(
asdf:find-system
system-name
)))
(
defun
clpm-bundle-install-validate-diff
(
diff
)
(
restart-case
(
progn
(
error
'clpm-bundle-install-diff
:diff
diff
))
(
continue
()
:report
"Accept and continue"
t
)
(
abort
()
:report
"Do not accept the diff"
nil
)))
(
defun
clpm-system-search-bundle
(
system-name
)
"ASDF search function for use inside a bundle. When inside a bundle exec, ASDF
is configured entirely through environment variables and that configuration is
exhaustive. If a system is missing, the best we can do is either reload the
config from the lock file (in case the lockfile has been modified outside this
process), or run a bundle install to propagate new dependencies and requirements
into the lock file and then reload the config."
(
flet
((
reload-config
()
(
asdf:clear-source-registry
)
(
asdf:initialize-source-registry
(
clpm-bundle-source-registry
))))
(
ecase
*clpm-system-not-found-behavior*
((
:install
:install-with-deps
)
(
clpm-bundle-install
)
(
reload-config
)
(
find-system-without-clpm
system-name
))
(
:error
(
restart-case
;; Prevent RESTART-CASE from using WITH-CONDITION-RESTARTS
(
signal-missing-system
system-name
)
(
install-and-reload-bundle
()
:report
"Run bundle install and reload configuration form clpmfile.lock"
(
when
(
clpm-bundle-install
:validate
'clpm-bundle-install-validate-diff
)
(
reload-config
)
(
asdf:find-system
system-name
)))
(
reload-bundle
()
:report
"Clear ASDF configuration and reload from clpmfile.lock."
(
reload-config
)
(
asdf:find-system
system-name
))))
((
nil
)
nil
))))
(
defun
clpm-system-search-no-bundle
(
system-name
)
"ASDF search function for use outside of a bundle, when global contexts are in
use."
(
let
((
primary-name
(
asdf:primary-system-name
system-name
)))
(
flet
((
lookup-system
()
(
clpm-context-find-system
primary-name
)))
(
or
(
lookup-system
)
(
ecase
*clpm-system-not-found-behavior*
(
:install
(
clpm-install-system
system-name
:no-deps-p
t
)
(
lookup-system
))
(
:install-with-deps
(
clpm-install-system
system-name
)
(
lookup-system
))
(
:error
(
restart-case
;; Prevent RESTART-CASE from using WITH-CONDITION-RESTARTS
(
signal-missing-system
system-name
)
(
install-system
()
:report
"Attempt to install the system using CLPM."
(
let
((
*clpm-system-not-found-behavior*
nil
))
(
clpm-install-system
system-name
:no-deps-p
t
)
(
lookup-system
)))
(
install-system-and-dependencies
()
:report
"Attempt to install the system and its dependencies using CLPM."
(
let
((
*clpm-system-not-found-behavior*
nil
))
(
clpm-install-system
system-name
)
(
lookup-system
)))
(
continue
()
:report
"Return control to ASDF."
nil
)))
((
nil
)
nil
))))))
(
defun
clpm-system-search
(
system-name
)
"A search function for ASDF's *SYSTEM-DEFINITION-SEARCH-FUNCTIONS* list.
...
...
@@ -78,69 +144,22 @@ 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
))
(
flet
((
lookup-system
()
(
gethash
primary-name
*clpm-installed-systems*
)))
(
or
(
lookup-system
)
(
ecase
*clpm-system-not-found-behavior*
(
:install
(
install-system-and-record-pathnames
system-name
:no-deps-p
t
)
(
lookup-system
))
(
:install-with-deps
(
install-system-and-record-pathnames
system-name
)
(
lookup-system
))
(
:error
(
maybe-restart-case
(
inside-bundle-exec-p
)
(
restart-case
;; The progn is necessary here to prevent RESTART-CASE from
;; using WITH-CONDITION-RESTARTS to associate the restarts with
;; only this condition. This becomes an issue for
;; :DEFSYSTEM-DEPENDS-ON, becuase this error will be signaled
;; in the middle of an ASDF DEFINE-OP and ASDF will catch it,
;; wrap it, and signal a new condition. If
;; WITH-CONDITION-RESTARTS is used in the expansion of this
;; macro, then these restarts won't be available in the
;; interactive debugger in this case.
(
progn
(
error
'clpm-missing-system
:system-name
system-name
))
(
install-system
()
:report
"Attempt to install the system using CLPM."
(
let
((
*clpm-system-not-found-behavior*
nil
))
(
install-system-and-record-pathnames
system-name
:no-deps-p
t
)
(
lookup-system
)))
(
install-system-and-dependencies
()
:report
"Attempt to install the system and its dependencies using CLPM."
(
let
((
*clpm-system-not-found-behavior*
nil
))
(
install-system-and-record-pathnames
system-name
)
(
lookup-system
)))
(
continue
()
:report
"Return control to ASDF."
nil
))
(
reload-bundle
()
:report
"Clear ASDF configuration and reload from clpmfile.lock."
(
asdf:clear-configuration
)
(
asdf:initialize-source-registry
'bundle-pathnames-for-asd-config
)
(
clpm-system-search
system-name
))))
((
nil
)
nil
)))))))
(
defun
clpm-active-p
()
(
if
(
clpm-inside-bundle-exec-p
)
(
clpm-system-search-bundle
system-name
)
(
clpm-system-search-no-bundle
system-name
)))))
(
defun
clpm-asdf-integration-active-p
()
"Returns T iff 'CLPM-SYSTEM-SEARCH is registered with ASDF's search functions."
(
member
'clpm-system-search
*system-definition-search-functions*
))
(
defun
activate-clpm
(
&key
force
(
order
:last
))
(
defun
activate-clpm
-asdf-integration
(
&key
force
(
order
:last
))
"Add 'CLPM-SYSTEM-SEARCH to ASDF's system definition search functions list.
Does nothing if CLPM-ACTIVE-P returns T and :FORCE is NIL.
Does nothing if CLPM-
ASDF-INTEGRATION-
ACTIVE-P returns T and :FORCE is NIL.
:ORDER can be one of:
...
...
@@ -149,7 +168,7 @@ Does nothing if CLPM-ACTIVE-P returns T and :FORCE is NIL.
+ :FIRST :: The CLPM search function is added to the front of ASDF's search functions."
(
when
(
or
force
(
not
(
clpm-active-p
)))
(
not
(
clpm-
asdf-integration-
active-p
)))
(
ecase
order
(
:last
(
setf
*system-definition-search-functions*
...
...
@@ -157,19 +176,10 @@ Does nothing if CLPM-ACTIVE-P returns T and :FORCE is NIL.
(
:first
(
push
'clpm-system-search
*system-definition-search-functions*
)))))
(
defun
deactivate-clpm
()
(
defun
deactivate-clpm
-asdf-integration
()
"Removes ~clpm-system-search~ from ASDF's search functions."
(
setf
*system-definition-search-functions*
(
remove
'clpm-system-search
*system-definition-search-functions*
)))
(
defun
clear-clpm-cache
()
(
setf
*clpm-installed-systems*
(
make-hash-table
:test
'equal
)))
(
uiop:register-clear-configuration-hook
'clear-clpm-cache
)
(
defun
clear-clpm-cache-hook
()
(
setf
uiop:*clear-configuration-hook*
(
remove
'clear-clpm-cache
uiop:*clear-configuration-hook*
)))
;; Unregister CLPM from ASDF on CLPM cleanup.
(
register-clpm-cleanup-hook
'deactivate-clpm
)
(
register-clpm-cleanup-hook
'clear-clpm-cache-hook
)
(
register-clpm-cleanup-hook
'deactivate-clpm-asdf-integration
)
src/clpm-client/bundle.lisp
View file @
015c8ab9
...
...
@@ -5,27 +5,26 @@
(
uiop:define-package
#:clpm-client/bundle
(
:use
#:cl
;; Everything must depend on header so that it comes first in the
;; concatenated file.
#:clpm-client/header
#:clpm-client/clpm
)
#:clpm-client/clpm
#:clpm-client/env
)
(
:import-from
#:uiop
#:getenv
#:pathname-directory-pathname
#:with-current-directory
)
(
:export
#:bundle-pathnames
#:bundle-pathnames-for-asd-config
(
:export
#:clpm-bundle-command
#:clpm-bundle-install
#:clpm-bundle-source-registry
#:clpmfile-pathname
#:inside-bundle-exec-p
))
#:
clpm-
inside-bundle-exec-p
))
(
in-package
#:clpm-client/bundle
)
(
defun
inside-bundle-exec-p
()
"Returns T iff we were spawned by a
~
clpm bundle exec
~
command."
(
defun
clpm-
inside-bundle-exec-p
()
"Returns T iff we were spawned by a
`
clpm bundle exec
`
command."
(
not
(
null
(
getenv
"CLPM_BUNDLE_CLPMFILE"
))))
(
defun
clpmfile-pathname
()
"If spawned by a
~
clpm bundle exec
~
command, return the pathname to the
"If spawned by a
`
clpm bundle exec
`
command, return the pathname to the
clpmfile."
(
pathname
(
getenv
"CLPM_BUNDLE_CLPMFILE"
)))
...
...
@@ -33,13 +32,53 @@ clpmfile."
"The directory pathname containing the clpmfile."
(
pathname-directory-pathname
(
clpmfile-pathname
)))
(
defun
bundle-pathnames
()
"Return a list of pathnames to ASD files that are part of this bundle."
(
with-current-directory
((
clpmfile-directory-pathname
))
(
uiop:split-string
(
run-clpm
'
(
"bundle"
"pathnames"
)
:output
'
(
:string
:stripped
t
))
:separator
'
(
#\Newline
))))
(
defun
clpm-bundle-command
()
"Return a command (list of string) suitable for invoking the same CLPM
executable that spawned this bundle exec environment."
(
let
((
bin
(
uiop:getenv
"CLPM_BUNDLE_BIN"
)))
(
if
bin
(
list
bin
)
(
let
((
live-script
(
uiop:getenv
"CLPM_BUNDLE_BIN_LIVE_SCRIPT"
))
(
lisp-implementation
(
uiop:getenv
"CLPM_BUNDLE_BIN_LISP_IMPLEMENTATION"
)))
(
cond
((
equalp
"sbcl"
lisp-implementation
)
(
list
"sbcl"
"--load"
live-script
"--"
))
(
t
(
error
"Unknown lisp implementation"
)))))))
(
defun
bundle-pathnames-for-asd-config
()
(
format
nil
"~{~A~^:~}"
(
bundle-pathnames
)))
(
defun
clpm-bundle-source-registry
()
"Return a source-registry form for this bundle."
(
uiop:with-safe-io-syntax
()
(
read-from-string
(
run-clpm
`
(
"bundle"
"source-registry"
"-f"
,
(
uiop:native-namestring
(
clpmfile-pathname
))
"--with-client"
)
:output
'
(
:string
:stripped
t
)))))
(
defun
clpm-bundle-install
(
&key
(
validate
(
constantly
t
)))
"Run `clpm bundle install`. VALIDATE will be called with a diff and its return
value is passed to the bindle install command. Returns T iff the command exited
successfully."
(
let*
((
proc
(
launch-clpm
`
(
"bundle"
"install"
"-f"
,
(
uiop:native-namestring
(
clpmfile-pathname
))
"--output"
"sexp"
)
:output
:stream
:input
:stream
:error-output
:stream
))
(
diff
(
uiop:with-safe-io-syntax
()
(
read
(
uiop:process-info-output
proc
)
nil
))))
(
when
diff
(
let
((
result
(
funcall
validate
diff
)))
(
uiop:with-safe-io-syntax
()
(
prin1
result
(
uiop:process-info-input
proc
))
(
terpri
(
uiop:process-info-input
proc
))
(
finish-output
(
uiop:process-info-input
proc
)))))
(
when
*clpm-dribble*
(
uiop:copy-stream-to-stream
(
uiop:process-info-error-output
proc
)
*clpm-dribble*
:linewise
t
:prefix
*clpm-dribble-prefix*
))
(
close
(
uiop:process-info-error-output
proc
))
(
close
(
uiop:process-info-input
proc
))
(
close
(
uiop:process-info-output
proc
))
(
zerop
(
uiop:wait-process
proc
))))
src/clpm-client/cleanup.lisp
View file @
015c8ab9
;;;; Cleaning up the client
on image dump
;;;; Cleaning up the client
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
(
uiop:define-package
#:clpm-client/cleanup
(
:use
#:cl
;; Everything must depend on header so that it comes first in the
;; concatenated file.
#:clpm-client/header
)
(
:use
#:cl
)
(
:export
#:*clpm-cleanup-on-dump-p*
#:cleanup-clpm!
#:register-clpm-cleanup-hook
))
...
...
@@ -16,44 +13,47 @@
(
defvar
*clpm-cleanup-on-dump-p*
t
"If non-NIL, CLPM will cleanup after itself if an image is dumped in a manner
that uses UIOP's image dump hooks. See
~cleanup-clpm!~
for details."
)
that uses UIOP's image dump hooks. See
CLEANUP-CLPM!
for details."
)
(
defvar
*clpm-cleanup-hooks*
nil
"List of functions to run in
~cleanup-clpm!~
."
)
"List of functions to run in
CLEANUP-CLPM!
."
)
(
defun
register-clpm-cleanup-hook
(
hook
)
"Register a new function to be called as part of CLEANUP-CLPM!."
(
pushnew
hook
*clpm-cleanup-hooks*
))
(
defun
clpm-package-p
(
p
)
(
defun
clpm-client-package-p
(
p
)
"Returns T iff P is a package belonging to the client."
(
let
((
package-name
(
package-name
p
)))
(
and
package-name
(
string-equal
"clpm-client"
(
first
(
uiop:split-string
package-name
:separator
'
(
#\/
)))))))
(
defun
cleanup-clpm!
(
&key
force
)
"If *CLPM-CLEANUP-ON-DUMP-P* is non-NIL or :FORCE is non-NIL, this function
performs the following steps:
(
defun
cleanup-clpm!
()
"Performs the following steps:
1. Removes
~:clpm-client~ from ~*features*~
1. Removes
:CLPM-CLIENT from *FEATURES*
2. Runs all hooks in
~*clpm-cleanup-hooks*~
.
2. Runs all hooks in
*CLPM-CLEANUP-HOOKS*
.
3. Removes
~'cleanup-clpm!~ from ~uiop:*image-dump-hook*~
3. Removes
'MAYBE-CLEANUP-CLPM! from UIOP:*IMAGE-DUMP-HOOK*
4. Deletes all packages that start with ~clpm-client/~."
(
when
(
or
*clpm-cleanup-on-dump-p*
force
)
;; Remove ourselves from *FEATURES*
(
setf
*features*
(
remove
:clpm-client
*features*
))
;; Run all cleanup hooks
(
mapc
'funcall
*clpm-cleanup-hooks*
)
;; Remove ourselves from UIOP's image dump hook
;; (setf asdf:*system-definition-search-functions*
;; (remove 'clpm-system-search asdf:*system-definition-search-functions*))
(
setf
uiop:*image-dump-hook*
(
remove
'cleanup-clpm!
uiop:*image-dump-hook*
))
;; Find all clpm-client packages and delete them.
(
let
((
packages
(
remove-if-not
'clpm-package-p
(
list-all-packages
))))
(
handler-bind
((
package-error
#'
continue
))
(
mapc
#'
delete-package
packages
)))))
4. Deletes all packages that start with CLPM-CLIENT/."
;; Remove ourselves from *FEATURES*
(
setf
*features*
(
remove
:clpm-client
*features*
))
;; Run all cleanup hooks
(
mapc
'funcall
*clpm-cleanup-hooks*
)
;; Remove ourselves from UIOP's image dump hook
(
setf
uiop:*image-dump-hook*
(
remove
'cleanup-clpm!
uiop:*image-dump-hook*
))
;; Find all clpm-client packages and delete them.
(
let
((
packages
(
remove-if-not
'clpm-client-package-p
(
list-all-packages
))))
(
handler-bind
((
package-error
#'
continue
))
(
mapc
#'
delete-package
packages
))))
(
defun
maybe-cleanup-clpm!
()
"Run CLEANUP-CLPM! iff *CLPM-CLEANUP-ON-DUMP-P* is non-NIL."
(
when
*clpm-cleanup-on-dump-p*
(
cleanup-clpm!
)))
;; Register our cleanup function with UIOP's image dump facilities.
(
uiop:register-image-dump-hook
'cleanup-clpm!
)
(
uiop:register-image-dump-hook
'
maybe-
cleanup-clpm!
)
src/clpm-client/clpm-client.asd
View file @
015c8ab9
...
...
@@ -7,7 +7,7 @@
(
error
"Requires ASDF >=3.2"
)
(
defsystem
#:clpm-client
:version
(
:read-file-form
"
header
.lisp"
:at
(
1
2
))
:version
(
:read-file-form
"
version
.lisp"
:at
(
2
2
))
:description
"A client for CLPM"
:license
"BSD-2-Clause"
:class
:package-inferred-system
...
...
src/clpm-client/clpm-client.lisp
View file @
015c8ab9
...
...
@@ -6,23 +6,30 @@
(
uiop:define-package
#:clpm-client/clpm-client
(
:nicknames
#:clpm-client
)
(
:use
#:cl
#:clpm-client/header
#:clpm-client/asdf
#:clpm-client/bundle
#:clpm-client/cleanup
#:clpm-client/clpm
)
#:clpm-client/clpm
#:clpm-client/version
)
(
:export
#:*clpm-cleanup-on-dump-p*
#:*clpm-context*
#:*clpm-executable*
#:*clpm-system-not-found-behavior*
#:activate-clpm
#:activate-clpm
-asdf-integration
#:cleanup-clpm!
#:clpm-active-p
#:clpm-
asdf-integration-
active-p
#:clpm-install-system
#:clpm-missing-system
#:clpm-client-version
#:clpm-inside-bundle-exec-p
#:clpm-version
#:clpmfile-pathname
#:deactivate-clpm
#:inside-bundle-exec-p
#:deactivate-clpm-asdf-integration
#:install-and-reload-bundle
#:install-system
#:install-system-and-dependencies
#:launch-clpm
#:reload-bundle
#:run-clpm
))
(
in-package
#:clpm-client
)
...
...
src/clpm-client/clpm.lisp
View file @
015c8ab9
...
...
@@ -4,11 +4,16 @@
;;;; LICENSE for license information.
(
uiop:define-package
#:clpm-client/clpm
(
:use
#:cl
)
(
:use
#:cl
#:clpm-client/cleanup
#:clpm-client/env
)
(
:import-from
#:uiop
#:launch-program
#:run-program
)
(
:export
#:*clpm-context*
(
:export
#:*clpm-dribble*
#:*clpm-dribble-prefix*
#:*clpm-executable*
#:launch-clpm
#:run-clpm
))
(
in-package
#:clpm-client/clpm
)
...
...
@@ -25,8 +30,11 @@
(
clpm-condition-code
c
)
(
clpm-condition-error-output
c
)))))
(
defvar
*clpm-context*
"default"
"The context to operate in when not operating in a bundle."
)
(
defvar
*clpm-dribble*
*error-output*
"The stream where clpm's stderr is copied."
)
(
defvar
*clpm-dribble-prefix*
"CLPM> "
"The prefix for lines to *CLPM-DRIBBLE*."
)
(
defvar
*clpm-executable*
nil
"The command to execute CLPM. If the clpm executable is not on your PATH,
...
...
@@ -37,19 +45,43 @@ change this to be an absolute path to the executable.")
executable that spawned us."
(
or
*clpm-executable*
(
setf
*clpm-executable*
(
or
(
uiop:getenv
"CLPM_BUNDLE_BIN_PATH"
)
"clpm"
))))
(
if
(
clpm-inside-bundle-exec-p
)
(
clpm-bundle-command
)
(
list
"clpm"
)))))
(
uiop:register-image-restore-hook
'compute-clpm-executable
)
(
defun
clear-clpm-executable
()
(
setf
*clpm-executable*
nil
))
(
uiop:register-image-dump-hook
'clear-clpm-executable
)
(
defun
clear-clpm-executable-hooks
()
(
setf
uiop:*image-restore-hook*
(
remove
'compute-clpm-executable
uiop:*image-restore-hook*
))
(
setf
uiop:*image-dump-hook*
(
remove
'clear-clpm-executable
uiop:*image-dump-hook*
)))
(
register-clpm-cleanup-hook
'clear-clpm-executable-hooks
)
(
defun
ensure-list
(
arg
)
(
if
(
listp
arg
)
arg
(
list
arg
)))
(
defun
run-clpm
(
command
&rest
args
&key
ignore-error-status
&allow-other-keys
)
"Run CLPM with ~command~. ~args~ are passed directly to ~uiop:run-program~."
(
multiple-value-bind
(
out
err-out
code
)
(
apply
#'
run-program
(
list
*
*clpm-executable*
command
)
(
append
(
ensure-
list
*clpm-executable*
)
command
)
:ignore-error-status
t
:error-output
'
(
:string
:stripped
t
)
args
)
(
when
*clpm-dribble*
(
with-input-from-string
(
s
err-out
)
(
uiop:copy-stream-to-stream
s
*clpm-dribble*
:linewise
t
:prefix
*clpm-dribble-prefix*
)))
(
unless
(
or
ignore-error-status
(
zerop
code
))
(
error
'clpm-condition
:error-output
err-out
:code
code
))
(
values
out
err-out
code
)))
(
defun
launch-clpm
(
command
&rest
args
&key
&allow-other-keys
)
"Launch CLPM with ~command~. ~args~ are passed directly to ~uiop:launch-program~."
(
apply
#'
launch-program
(
append
(
ensure-list
*clpm-executable*
)
command
)
args
))
src/clpm-client/context.lisp
0 → 100644
View file @
015c8ab9
;;;; CLPM Context
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
(
uiop:define-package
#:clpm-client/context
(
:use
#:cl
#:clpm-client/clpm
)
(
:export
#:*clpm-context*
#:clpm-context-asd-directories
#:clpm-context-asd-pathnames
#:clpm-context-find-system
))
(
in-package
#:clpm-client/context
)
(
defvar
*clpm-context*
"default"
"The context to operate in when not operating in a bundle."
)
(
defun
clpm-context-asd-pathnames
(
&optional
(
context
*clpm-context*
))
"Given a context name, return a list of pathnames to .asd files installed in
that context."
(
let
((
pathnames-string
(
ignore-errors
(
run-clpm
`
(
"context"
"pathnames"
"--output=sexp"
,
context
)
:output
'
(
:string
:stripped
t
)))))
(
when
pathnames-string
(
uiop:with-safe-io-syntax
()
(
read-from-string
pathnames-string
)))))
(
defun
clpm-context-asd-directories
(
&optional
(
context
*clpm-context*
))
"Return the directories containing the .asd files installed in CONTEXT."
(
remove-duplicates
(
mapcar
#'
pathname-directory
(
clpm-context-asd-pathnames
context
))
:test
#'
uiop:pathname-equal
))
(
defun
clpm-context-find-system
(
system-name
&key
(
context
*clpm-context*
))
"Find the pathname to a system in the given context."
(
multiple-value-bind
(
output
error-output
code
)
(
run-clpm
`
(
"context"
"find"
"--context"
,
context
"--output=sexp"
,
system-name
)
:output
'
(
:string
:stripped
t
)
:ignore-error-status
t
)
(
declare
(
ignore
error-output
))