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
81bf9afc
Commit
81bf9afc
authored
May 19, 2020
by
Eric Timmons
Browse files
Replace most GET-CONTEXTs with WITH-CONTEXT
This allows us to set dynamic vars based on the context
parent
34c3ec53
Changes
5
Hide whitespace changes
Inline
Side-by-side
clpm/context-queries.lisp
View file @
81bf9afc
...
...
@@ -19,28 +19,36 @@
(
defun
asd-pathnames
(
&key
context
)
(
with-clpm-session
()
(
context-asd-pathnames
(
get-context
context
))))
(
with-context
(
context
)
(
context-asd-pathnames
context
))))
(
defun
find-system-asd-pathname
(
system-name
&key
context
)
(
with-clpm-session
()
(
context-find-system-asd-pathname
(
get-context
context
)
system-name
)))
(
with-context
(
context
)
(
context-find-system-asd-pathname
context
system-name
))))
(
defun
installed-system-names
(
&key
context
)
(
mapcar
'system-name
(
context-installed-systems
(
get-context
context
))))
(
with-clpm-session
()
(
with-context
(
context
)
(
mapcar
'system-name
(
context-installed-systems
context
)))))
(
defun
output-translations
(
&key
context
)
(
with-clpm-session
()
(
context-output-translations
(
get-context
context
))))
(
with-context
(
context
)
(
context-output-translations
context
))))
(
defun
source-registry
(
&key
context
with-client-p
ignore-inherited-source-registry
splice-inherited
)
(
with-clpm-session
()
(
context-to-asdf-source-registry-form
(
get-context
context
)
:with-client
with-client-p
:ignore-inherited
ignore-inherited-source-registry
:splice-inherited
splice-inherited
)))
(
with-context
(
context
)
(
context-to-asdf-source-registry-form
context
:with-client
with-client-p
:ignore-inherited
ignore-inherited-source-registry
:splice-inherited
splice-inherited
))))
(
defun
visible-primary-system-names
(
&key
context
)
(
context-visible-primary-system-names
(
get-context
context
)))
(
with-clpm-session
()
(
with-context
(
context
)
(
context-visible-primary-system-names
context
))))
clpm/context.lisp
View file @
81bf9afc
...
...
@@ -37,11 +37,11 @@
#:context-visible-primary-system-names
#:context-write-asdf-files
#:copy-context
#:get-context
#:load-anonymous-context-from-pathname
#:load-global-context
#:save-context
#:serialize-context-to-stream
))
#:serialize-context-to-stream
#:with-context
))
(
in-package
#:clpm/context
)
...
...
@@ -125,6 +125,27 @@ can be named, global contexts, or anonymous."))
(
context-vcs-source
context
)
(
context-user-sources
context
)))
(
defun
make-vcs-override-fun
(
root-pathname
)
(
let
((
root-pathname
(
uiop:pathname-directory-pathname
root-pathname
)))
(
lambda
(
project-name
)
(
let
((
override
(
config-value
:bundle
:local
project-name
)))
(
when
override
(
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
)))
(
*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
))))
(
defmacro
with-context
((
context-var
&optional
(
context-value
context-var
))
&body
body
)
`
(
call-with-context
(
lambda
(
,
context-var
)
,@
body
)
,
context-value
))
;; * Adding requirements
...
...
clpm/exec.lisp
View file @
81bf9afc
...
...
@@ -26,29 +26,29 @@ 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
()
(
let*
((
context
(
get-
context
context
)
)
(
context-name
(
context-name
context
))
(
ignore-inherited-source-registry
(
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
:with-client
with-client-p
:ignore-inherited
ignore-inherited-source-registry
:splice-inherited
splice-inherited
))
(
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
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
)
(
"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
)))))
(
with-
context
(
context
)
(
let*
(
(
context-name
(
context-name
context
))
(
ignore-inherited-source-registry
(
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
:with-client
with-client-p
:ignore-inherited
ignore-inherited-source-registry
:splice-inherited
splice-inherited
))
(
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
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
)
(
"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
)
)))))
clpm/install.lisp
View file @
81bf9afc
...
...
@@ -99,39 +99,39 @@ 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
()
(
let
((
context
(
get
-context
context
)
)
(
reqs
(
append
(
mapcar
(
rcurry
#'
make-requirement
:project
:version
version
:source
source
:ref
ref
:no-deps-p
no-deps-p
)
projects
)
(
mapcar
(
rcurry
#'
make-requirement
:system
:version
version
:source
source
:ref
ref
:no-deps-p
no-deps-p
)
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
))))
(
with
-context
(
context
)
(
let
(
(
reqs
(
append
(
mapcar
(
rcurry
#'
make-requirement
:project
:version
version
:source
source
:ref
ref
:no-deps-p
no-deps-p
)
projects
)
(
mapcar
(
rcurry
#'
make-requirement
:system
:version
version
:source
source
:ref
ref
:no-deps-p
no-deps-p
)
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
context
(
validate
(
constantly
t
))
save-context-p
update-projects
)
(
let*
((
orig
-context
(
get
-context
context
)
)
(
new-context
(
copy-context
orig-context
))
)
(
dolist
(
r
reqs
)
(
context-add-requirement!
new-context
r
))
(
setf
new-context
(
resolve-requirements
new-context
:update-projects
update-projects
))
(
let
((
result
(
funcall
validate
(
make-context-diff
orig-context
new-context
))))
(
if
result
(
progn
(
mapc
#'
install-release
(
context-releases
new-context
))
(
when
save-context-p
(
context-write-asdf-files
new-context
)
(
save-context
new-context
))
new-context
)
orig-context
))))
(
with
-context
(
orig
-context
context
)
(
with-context
(
new-context
(
copy-context
orig-context
))
(
dolist
(
r
reqs
)
(
context-add-requirement!
new-context
r
))
(
setf
new-context
(
resolve-requirements
new-context
:update-projects
update-projects
))
(
let
((
result
(
funcall
validate
(
make-context-diff
orig-context
new-context
))))
(
if
result
(
progn
(
mapc
#'
install-release
(
context-releases
new-context
))
(
when
save-context-p
(
context-write-asdf-files
new-context
)
(
save-context
new-context
))
new-context
)
orig-context
))))
)
clpm/update.lisp
View file @
81bf9afc
...
...
@@ -23,21 +23,21 @@
(
validate
(
constantly
t
))
context
)
(
with-clpm-session
()
(
let*
((
orig
-context
(
get
-context
context
)
)
(
context
(
copy-context
orig-context
))
)
;; Map all systems to their corresponding projects.
(
dolist
(
system
update-systems
)
(
when-let*
((
system-release
(
find
system
(
context-system-releases
orig-context
)
:key
(
compose
#'
system-name
#'
system-release-system
)
:test
#'
equal
))
(
release
(
system-release-release
system-release
))
(
project-name
(
project-name
(
release-project
release
))))
(
pushnew
project-name
update-projects
:test
#'
equal
)))
(
with
-context
(
orig
-context
context
)
(
with-context
(
context
(
copy-context
orig-context
))
;; Map all systems to their corresponding projects.
(
dolist
(
system
update-systems
)
(
when-let*
((
system-release
(
find
system
(
context-system-releases
orig-context
)
:key
(
compose
#'
system-name
#'
system-release-system
)
:test
#'
equal
))
(
release
(
system-release-release
system-release
))
(
project-name
(
project-name
(
release-project
release
))))
(
pushnew
project-name
update-projects
:test
#'
equal
)))
(
log:info
"Updating ~:[all~;~:*~{~A~^, ~}~] projects."
update-projects
)
(
let*
((
new-context
(
resolve-requirements
context
:update-projects
(
or
update-projects
t
)))
(
diff
(
make-context-diff
orig-context
new-context
)))
(
when
(
funcall
validate
diff
)
(
mapc
#'
install-release
(
context-releases
new-context
))
(
context-write-asdf-files
new-context
)
(
save-context
new-context
))))))
(
log:info
"Updating ~:[all~;~:*~{~A~^, ~}~] projects."
update-projects
)
(
let*
((
new-context
(
resolve-requirements
context
:update-projects
(
or
update-projects
t
)))
(
diff
(
make-context-diff
orig-context
new-context
)))
(
when
(
funcall
validate
diff
)
(
mapc
#'
install-release
(
context-releases
new-context
))
(
context-write-asdf-files
new-context
)
(
save-context
new-context
))))))
)
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