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
e13e02ec
Commit
e13e02ec
authored
May 18, 2020
by
Eric Timmons
Browse files
Allow .asds to be installed in global contexts
parent
f5b49412
Changes
9
Hide whitespace changes
Inline
Side-by-side
cli/commands/exec.lisp
View file @
e13e02ec
...
...
@@ -38,17 +38,18 @@
(
define-cli-command
((
"exec"
)
*exec-ui*
)
(
args
options
)
(
let*
((
context-name
(
config-value
:context
))
(
context
(
get-context
context-name
))
(
with-client
(
gethash
:exec-with-client
options
))
(
ignore-inherited
(
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
-name
context
:with-client
with-client
:ignore-inherited
ignore-inherited
:splice-inherited
splice-inherited
))
(
output-translations
(
context-output-translations
context
-name
))
(
installed-system-names
(
sort
(
mapcar
#'
system-name
(
context-installed-systems
context
-name
))
#'
string<
))
(
visible-primary-system-names
(
sort
(
context-visible-primary-system-names
context
-name
)
#'
string<
)))
(
output-translations
(
context-output-translations
context
))
(
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
(
execvpe
(
first
args
)
(
rest
args
)
`
((
"CL_SOURCE_REGISTRY"
.
,
(
prin1-to-string
source-registry
))
...
...
cli/commands/install.lisp
View file @
e13e02ec
...
...
@@ -65,6 +65,14 @@ with version constraint).
:help
"The name of the source to install from"
:reduce
#'
adopt:last
))
(
defparameter
*option-install-asd*
(
adopt:make-option
:install-asds
:long
"asd"
:parameter
"ASD-PATH"
:help
"Install an .asd file into the context"
:reduce
(
adopt:flip
#'
cons
)))
(
defparameter
*option-install-project*
(
adopt:make-option
:install-projects
...
...
@@ -102,6 +110,7 @@ with version constraint).
*option-install-version*
*option-install-source*
*option-install-project*
*option-install-asd*
*option-install-no-deps*
*option-yes*
*option-local*
...
...
@@ -112,6 +121,7 @@ with version constraint).
(
let*
((
version-string
(
gethash
:install-version
options
))
(
system-specifiers
args
)
(
project-specifiers
(
gethash
:install-projects
options
))
(
asd-files
(
gethash
:install-asds
options
))
(
source-name
(
gethash
:install-source
options
))
(
no-deps-p
(
gethash
:install-no-deps
options
))
(
context-name
(
config-value
:context
))
...
...
@@ -119,6 +129,7 @@ with version constraint).
(
ref
(
gethash
:install-ref
options
)))
(
install
:projects
project-specifiers
:systems
system-specifiers
:asds
(
mapcar
#'
merge-pathnames
asd-files
)
:version
version-string
:source
source-name
:context
context-name
...
...
clpm/context.lisp
View file @
e13e02ec
...
...
@@ -143,6 +143,10 @@ can be named, global contexts, or anonymous."))
in place with the same name. Return the new requirement if it was modified."
(
let
((
existing-req
(
context-find-requirement
context
(
requirement-type-keyword
req
)
(
requirement-name
req
))))
(
when
(
typep
req
'fs-system-file-requirement
)
(
fs-source-register-asd
(
context-fs-source
context
)
(
requirement-name
req
)))
(
when
(
typep
req
'fs-system-requirement
)
(
fs-source-register-asd
(
context-fs-source
context
)
(
requirement-pathname
req
)))
(
if
existing-req
(
progn
(
log:debug
"Replacing requirement ~A with ~A"
existing-req
req
)
...
...
@@ -320,38 +324,38 @@ in place with the same name. Return the new requirement if it was modified."
(
defmethod
process-form
(
context
(
section
(
eql
:requirements
))
form
)
(
destructuring-bind
(
type
&key
name
version
source
branch
tag
commit
ref
pathname
no-deps-p
)
form
(
push
(
cond
((
eql
type
:asd-system
)
(
make-instance
'fs-system-requirement
:name
name
:path
name
path
name
:no-deps-p
no-deps-p
:why
t
))
((
eql
type
:asd-file
)
(
make-instance
'fs-system-file-requirement
:name
pathname
:no-deps-p
no-deps-p
:why
t
))
((
or
branch
tag
commit
ref
)
(
make-instance
'vcs-project-requirement
:name
name
:source
(
get-source
source
)
:commit
commit
:branch
branch
:tag
tag
:ref
ref
:no-deps-p
no-deps-p
:why
t
))
(
t
(
make-instance
(
ecase
type
(
:system
'system-requirement
)
(
:project
'project
-requirement
)
)
:name
name
:source
(
get-source
source
)
:version-spec
version
:no-deps-p
no-deps-p
:why
t
)))
(
context-requirements
context
))))
(
context-add-requirement!
context
(
cond
((
eql
type
:asd-system
)
(
make-instance
'fs-system-requirement
:
name
name
:pathname
pathname
:no-deps-p
no-deps-p
:why
t
)
)
((
eql
type
:asd-file
)
(
make-instance
'fs-system-file-requirement
:name
name
:no-deps-p
no-deps-p
:why
t
)
)
((
or
branch
tag
commit
ref
)
(
make-instance
'vcs-project-requirement
:name
name
:source
(
get-source
source
)
:commit
commit
:branch
branch
:tag
tag
:ref
ref
:no-deps-p
no-deps-p
:why
t
))
(
t
(
make-instance
(
ecase
type
(
:system
'system
-requirement
)
(
:project
'project-requirement
))
:name
name
:source
(
get-source
source
)
:version-spec
version
:no-deps-p
no-deps-p
:why
t
))
))))
(
defmethod
process-form
(
context
(
section
(
eql
:releases
))
form
)
(
destructuring-bind
(
name
&key
version
source
systems
)
form
...
...
@@ -457,12 +461,11 @@ in place with the same name. Return the new requirement if it was modified."
(
format
stream
":releases~%"
)
(
dolist
(
release
(
sort
(
copy-list
(
context-releases
context
))
#'
string<
:key
(
compose
#'
project-name
#'
release-project
)))
(
unless
(
typep
release
'fs-release
)
(
format
stream
"~S~%"
(
context-release-to-form
release
(
remove-if-not
(
lambda
(
x
)
(
eql
x
release
))
(
context-system-releases
context
)
:key
#'
system-release-release
)))))
(
format
stream
"~S~%"
(
context-release-to-form
release
(
remove-if-not
(
lambda
(
x
)
(
eql
x
release
))
(
context-system-releases
context
)
:key
#'
system-release-release
))))
(
terpri
stream
)
(
terpri
stream
)
...
...
clpm/install.lisp
View file @
e13e02ec
...
...
@@ -81,7 +81,7 @@
:version-spec
version-spec
common-args
))))))
(
defun
install
(
&key
projects
systems
(
defun
install
(
&key
projects
systems
asds
version
ref
source
no-deps-p
(
validate
(
constantly
t
))
...
...
@@ -93,6 +93,9 @@ PROJECTS and SYSTEMS must be lists of dependency specifiers. VERSION, REF, and
SOURCE must be strings and are used as the default constraints on PROJECTS and
SYSTEMS if such constraints cannot be extracted from the specifiers themselves.
ASDs must be a list of pathnames to .asd files. All systems in each .asd file
will be installed.
VALIDATE must be a function of one argument (a diff) and returns non-NIL if the
install should proceed."
(
with-clpm-session
()
...
...
@@ -103,7 +106,13 @@ install should proceed."
(
mapcar
(
rcurry
#'
make-requirement
:system
:version
version
:source
source
:ref
ref
:no-deps-p
no-deps-p
)
systems
))))
systems
)
(
mapcar
(
lambda
(
x
)
(
make-instance
'fs-system-file-requirement
:name
x
:why
t
:no-deps-p
no-deps-p
))
asds
))))
(
install-requirements
reqs
:context
context
:validate
validate
:save-context-p
save-context-p
))))
(
defun
install-requirements
(
reqs
&key
...
...
clpm/requirement.lisp
View file @
e13e02ec
...
...
@@ -232,13 +232,13 @@ represents."))
(
defmethod
requirement-to-plist
((
req
fs-system-requirement
))
(
append
(
list
:pathname
(
requirement-pathname
req
)
(
list
:pathname
(
namestring
(
requirement-pathname
req
)
)
:name
(
requirement-name
req
))
(
awhen
(
requirement-no-deps-p
req
)
(
list
:no-deps-p
it
))))
(
defmethod
requirement-to-plist
((
req
fs-system-file-requirement
))
(
append
(
list
:
path
name
(
requirement-
path
name
req
))
(
list
:name
(
namestring
(
requirement-name
req
))
)
(
awhen
(
requirement-no-deps-p
req
)
(
list
:no-deps-p
it
))))
clpm/resolve.lisp
View file @
e13e02ec
...
...
@@ -100,19 +100,19 @@
"Given a context, return a new context that has the same requirements but the
set of installed releases is updated to be the minimum set that satisfies all
the requirements."
(
let*
((
*
sources
*
(
context-sources
context
))
(
*releases-sort-function*
(
unless
(
eql
update-projects
t
)
(
make-result-sorter
context
update-projects
)))
(
reqs
(
rewrite-vcs-reqs
(
context-requirements
context
)
context
update-projects
))
(
out-context
(
copy-context
context
))
(
root-node
(
make-instance
'node
:unresolved-reqs
reqs
:groveler
(
make-groveler
)))
(
final-node
(
perform-search
root-node
)))
(
setf
(
context-releases
out-context
)
(
mapcar
#'
car
(
node-activated-releases
final-node
)))
(
setf
(
context-reverse-dependencies
out-context
)
(
sort
(
copy-alist
(
node-activated-releases
final-node
))
#'
string<
:key
(
compose
#'
project-name
#'
release-project
#'
car
)))
(
setf
(
context-system-releases
out-context
)
(
node-activated-system-releases
final-node
))
out-context
))
(
with-
sources
(
(
context-sources
context
))
(
let*
(
(
*releases-sort-function*
(
unless
(
eql
update-projects
t
)
(
make-result-sorter
context
update-projects
)))
(
reqs
(
rewrite-vcs-reqs
(
context-requirements
context
)
context
update-projects
))
(
out-context
(
copy-context
context
))
(
root-node
(
make-instance
'node
:unresolved-reqs
reqs
:groveler
(
make-groveler
)))
(
final-node
(
perform-search
root-node
)))
(
setf
(
context-releases
out-context
)
(
mapcar
#'
car
(
node-activated-releases
final-node
)))
(
setf
(
context-reverse-dependencies
out-context
)
(
sort
(
copy-alist
(
node-activated-releases
final-node
))
#'
string<
:key
(
compose
#'
project-name
#'
release-project
#'
car
)))
(
setf
(
context-system-releases
out-context
)
(
node-activated-system-releases
final-node
))
out-context
))
)
clpm/resolve/defs.lisp
View file @
e13e02ec
...
...
@@ -6,16 +6,12 @@
(
uiop:define-package
#:clpm/resolve/defs
(
:use
#:cl
#:clpm/log
)
(
:export
#:*sources*
#:provided-system-p
))
(
:export
#:provided-system-p
))
(
in-package
#:clpm/resolve/defs
)
(
setup-logger
)
(
defvar
*sources*
nil
"The sources that can be used during resolution."
)
(
defparameter
*sb-contribs*
'
(
"sb-aclrepl"
"sb-bsd-sockets"
"sb-capstone"
"sb-cltl2"
"sb-concurrency"
"sb-cover"
"sb-executable"
"sb-gmp"
"sb-grovel"
"sb-introspect"
"sb-md5"
"sb-mpfr"
"sb-posix"
...
...
clpm/resolve/requirement.lisp
View file @
e13e02ec
...
...
@@ -27,13 +27,13 @@
(
defun
find-project-source
(
project-name
)
(
loop
:for
source
:in
*
sources
*
:for
source
:in
(
sources
)
:when
(
source-project
source
project-name
nil
)
:do
(
return
source
)))
(
defun
find-system-source
(
system-name
)
(
loop
:for
source
:in
*
sources
*
:for
source
:in
(
sources
)
:when
(
source-system
source
system-name
nil
)
:do
(
return
source
)))
...
...
@@ -52,19 +52,19 @@ to searching."
(
error
"Unable to find a source for requirement ~S"
req
)))))
(
defmethod
find-requirement-source
((
req
project-requirement
)
&optional
errorp
)
"Find the first source in
*
SOURCES
*
that provides the project. ERRORP is
"Find the first source in
(
SOURCES
)
that provides the project. ERRORP is
handled by an :AROUND method."
(
declare
(
ignore
errorp
))
(
find-project-source
(
requirement-name
req
)))
(
defmethod
find-requirement-source
((
req
system-requirement
)
&optional
errorp
)
"Find the first source in
*
SOURCES
*
that provides the system. ERRORP is andled
"Find the first source in
(
SOURCES
)
that provides the system. ERRORP is andled
by an :AROUND method."
(
declare
(
ignore
errorp
))
(
find-system-source
(
requirement-name
req
)))
(
defmethod
find-requirement-source
((
req
vcs-project-requirement
)
&optional
errorp
)
"Find the first source in
*
SOURCES
*
that provides the project. ERRORP is
"Find the first source in
(
SOURCES
)
that provides the project. ERRORP is
handled by an :AROUND method."
(
declare
(
ignore
errorp
))
(
find-project-source
(
requirement-name
req
)))
...
...
@@ -83,7 +83,7 @@ satisfied. Returns one of :SAT, :UNSAT, or :UNKNOWN."))
((
not
system-release
)
:unknown
)
((
not
(
eql
(
system-release-source
system-release
)
(
requirement-source
req
)))
(
get-source
:implicit-file
)))
:unsat
)
(
t
:sat
))))
...
...
@@ -150,7 +150,7 @@ a plist. This plist can contain :system-releases or :system-files."))
(
defmethod
resolve-requirement
((
req
fs-system-requirement
)
node
)
;; Make a release from the file system.
(
let*
((
system-name
(
requirement-name
req
))
(
fs-source
(
requirement-source
req
))
(
fs-source
(
get-source
:implicit-file
))
(
system
(
source-system
fs-source
system-name
))
(
releases
(
system-releases
system
))
(
release
(
first
releases
))
...
...
@@ -164,7 +164,7 @@ a plist. This plist can contain :system-releases or :system-files."))
(
defmethod
resolve-requirement
((
req
fs-system-file-requirement
)
node
)
;; Make a release from the file system.
(
let*
((
asd-pathname
(
requirement-name
req
))
(
fs-source
(
requirement-source
req
))
(
fs-source
(
get-source
:implicit-file
))
(
release
(
source-project-release
fs-source
(
namestring
asd-pathname
)
:newest
)))
(
list
(
list
release
:system-files
(
list
(
cons
(
release-system-file
release
asd-pathname
)
t
))))))
...
...
clpm/sources/fs.lisp
View file @
e13e02ec
...
...
@@ -74,7 +74,7 @@ source using FS-SOURCE-REGISTER-ASD."))
t
)
(
defmethod
source-project
((
source
fs-source
)
project-name
&optional
(
error
t
))
(
or
(
gethash
project-name
(
fs-source-projects-by-namestring
source
))
(
or
(
gethash
(
namestring
project-name
)
(
fs-source-projects-by-namestring
source
))
(
when
error
(
error
'source-missing-project
:source
source
...
...
@@ -112,7 +112,8 @@ can be relative or absolute."
(
namestring-ht
(
fs-source-system-files-by-namestring
fs-source
))
(
namestring
(
namestring
asd-pathname
))
(
project-ht
(
fs-source-projects-by-namestring
fs-source
))
(
project
(
make-instance
'fs-project
:name
namestring
:source
fs-source
)))
(
project
(
or
(
gethash
namestring
project-ht
)
(
make-instance
'fs-project
:name
namestring
:source
fs-source
))))
(
setf
(
gethash
namestring
project-ht
)
project
)
(
aprog1
(
ensure-gethash
(
pathname-name
namestring
)
primary-name-ht
(
make-instance
'fs-system-file
...
...
@@ -127,7 +128,7 @@ can be relative or absolute."
(
let*
((
system-files
(
hash-table-keys
(
fs-source-projects-by-namestring
source
))))
`
(
,
(
source-name
source
)
:type
:file-system
:system-files
,
(
mapcar
#'
system-file-asd-enough-namestring
system-files
)))
)
:system-files
,
system-files
)))
(
defmethod
sync-source
((
source
fs-source
))
nil
)
...
...
@@ -189,7 +190,7 @@ of this created upon instantiation."))
"Look at the fs-source to get the system file."
(
let*
((
source
(
release-source
release
))
(
ht
(
fs-source-system-files-by-namestring
source
)))
(
gethash
system-file-namestring
ht
)))
(
gethash
(
namestring
system-file-namestring
)
ht
)))
(
defmethod
release-system-files
((
release
fs-release
))
"Projects (and releases) correspond to a single system file."
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment