Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
clpm
clpm
Commits
79c65603
Commit
79c65603
authored
May 29, 2020
by
Eric Timmons
Browse files
Delay resolving system-release objects when loading contexts
parent
dad72e48
Changes
5
Hide whitespace changes
Inline
Side-by-side
clpm/bundle.lisp
View file @
79c65603
...
...
@@ -85,10 +85,11 @@ the lock file if necessary."
(
sync-source
s
))))
;; Map all update systems to their projects.
(
dolist
(
system
update-systems
)
(
when-let*
((
system-release
(
find
system
(
context-system-releases
lockfile
)
:key
(
compose
#'
system-name
#'
system-release-system
)
:test
#'
equal
))
(
release
(
system-release-release
system-release
))
(
when-let*
((
release-cons
(
find-if
(
lambda
(
x
)
(
member
system
x
:test
#'
equal
))
(
context-system-releases
lockfile
)
:key
#'
cdr
))
(
release
(
car
release-cons
))
(
project-name
(
project-name
(
release-project
release
))))
(
pushnew
project-name
update-projects
:test
#'
equal
)))
;; Nuke the lockfile's requirements so that we pick up deletions
...
...
clpm/clpi.lisp
View file @
79c65603
...
...
@@ -76,10 +76,13 @@
(
let*
((
missing-system-spec
(
groveler-dependency-missing-system
c
))
(
missing-req
(
convert-asd-system-spec-to-req
missing-system-spec
))
(
missing-system-name
(
requirement-name
missing-req
))
(
matching-sr
(
find
missing-system-name
(
context-system-releases
clpmfile
)
:test
#'
equal
:key
(
compose
#'
system-name
#'
system-release-system
))))
(
matching-cons
(
find-if
(
lambda
(
x
)
(
member
missing-system-name
x
:test
#'
equal
))
(
context-system-releases
clpmfile
)
:key
#'
cdr
))
(
matching-sr
(
when
matching-cons
(
release-system-release
(
car
matching-cons
)
missing-system-name
))))
(
when
(
and
matching-sr
(
system-release-satisfies-version-spec-p
matching-sr
...
...
clpm/context.lisp
View file @
79c65603
...
...
@@ -83,7 +83,12 @@ pathname (if this is an anonymous context).")
(
system-releases
:initform
nil
:initarg
:system-releases
:accessor
context-system-releases
))
:accessor
context-system-releases
:documentation
"An alist mapping release objects to strings naming the systems installed as
part of the release. SYSTEM-RELEASE objects must *not* be used here, because
they are not guaranteed to be constructable when the context is read (e.g.,
in the case of VCS repos where commits have been deleted)."
))
(
:documentation
"Represents a snapshot of a context. Includes sources, the releases installed
in the context, the requirements that gave rise to those releases, etc. Contexts
...
...
@@ -128,7 +133,7 @@ can be named, global contexts, or anonymous."))
:requirements
(
copy-list
(
context-requirements
context
))
:reverse-dependencies
(
copy-alist
(
context-reverse-dependencies
context
))
:user-sources
(
copy-list
(
context-user-sources
context
))
:system-releases
(
copy-
list
(
context-system-releases
context
))))
:system-releases
(
copy-
tree
(
context-system-releases
context
))))
(
defun
global-context-pathname
(
name
)
(
clpm-data-pathname
(
list
"contexts"
name
)))
...
...
@@ -229,18 +234,24 @@ in place with the same name. Return the new requirement if it was modified."
(
let*
((
context
(
get-context
context
))
(
system-releases
(
context-system-releases
context
)))
(
remove-duplicates
(
mapcar
(
compose
#'
asdf:primary-system-name
#'
system-name
#'
system-release-system
)
system-releases
)
(
mappend
(
lambda
(
x
)
(
mapcar
#'
asdf:primary-system-name
(
cdr
x
)))
system-releases
)
:test
#'
equal
)))
(
defun
context-installed-systems
(
context
)
(
let*
((
context
(
get-context
context
))
(
system-releases
(
context-system-releases
context
)))
(
map
car
#'
system-release-system
system-releases
)))
(
map
pend
#'
cdr
system-releases
)))
(
defun
context-visible-primary-system-names
(
context
)
(
let*
((
context
(
get-context
context
))
(
releases
(
context-releases
context
))
(
system-releases
(
context-system-releases
context
))
(
system-release-alist
(
context-system-releases
context
))
(
system-releases
(
mappend
(
lambda
(
x
)
(
mapcar
(
lambda
(
system-name
)
(
release-system-release
(
car
x
)
system-name
))
(
cdr
x
)))
system-release-alist
))
(
system-files
(
remove-duplicates
(
mapcar
#'
system-release-system-file
system-releases
)))
(
system-file-directories
(
remove-duplicates
(
mapcar
(
compose
#'
uiop:pathname-directory-pathname
#'
system-file-absolute-asd-pathname
)
...
...
@@ -283,9 +294,11 @@ in place with the same name. Return the new requirement if it was modified."
(
defun
context-find-system-asd-pathname
(
context
system-name
)
(
when-let*
((
context
(
get-context
context
))
(
system-release
(
find
system-name
(
context-system-releases
context
)
:key
(
compose
#'
system-name
#'
system-release-system
)
:test
#'
equal
)))
(
system-release-cons
(
find-if
(
lambda
(
x
)
(
member
system-name
x
:test
'equal
))
(
context-system-releases
context
)
:key
#'
cdr
))
(
system-release
(
release-system-release
(
car
system-release-cons
)
system-name
)))
(
system-release-absolute-asd-pathname
system-release
)))
(
defun
context-write-asdf-files
(
context
)
...
...
@@ -433,8 +446,8 @@ in place with the same name. Return the new requirement if it was modified."
(
push
release
(
context-releases
context
))
(
dolist
(
system-name
systems
)
(
push
(
release-system-release
release
system-name
)
(
context-system-releases
context
))))))
(
push
system-name
(
assoc-value
(
context-system-releases
context
)
release
)
)))))
(
defmethod
process-form
(
context
(
section
(
eql
:reverse-dependencies
))
form
))
...
...
@@ -541,10 +554,8 @@ in place with the same name. Return the new requirement if it was modified."
(
dolist
(
release
(
sort
(
copy-list
(
context-releases
context
))
#'
string<
:key
(
compose
#'
project-name
#'
release-project
)))
(
format
stream
"~S~%"
(
context-release-to-form
release
(
remove-if-not
(
lambda
(
x
)
(
eql
x
release
))
(
context-system-releases
context
)
:key
#'
system-release-release
))))
(
context-release-to-form
release
(
assoc-value
(
context-system-releases
context
)
release
))))
(
terpri
stream
)
(
terpri
stream
)
...
...
@@ -570,11 +581,11 @@ in place with the same name. Return the new requirement if it was modified."
,
(
list*
(
requirement-type-keyword
req
)
(
requirement-to-plist
req
)))))
(
defun
context-release-to-form
(
release
system-
releas
es
)
(
defun
context-release-to-form
(
release
system-
nam
es
)
`
(
,
(
project-name
(
release-project
release
))
:version
,
(
release-version
release
)
:source
,
(
source-name
(
release-source
release
))
:systems
,
(
mapcar
(
compose
#'
system-name
#'
system-release-system
)
system-releases
)
))
:systems
,
system-names
))
(
defun
context-reverse-deps-to-form
(
release-and-reverse-deps
)
(
destructuring-bind
(
release
.
reverse-deps
)
release-and-reverse-deps
...
...
clpm/resolve.lisp
View file @
79c65603
...
...
@@ -114,5 +114,8 @@ the requirements."
(
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
))
(
setf
(
context-system-releases
out-context
)
nil
)
(
dolist
(
sr
(
node-activated-system-releases
final-node
))
(
push
(
system-name
(
system-release-system
sr
))
(
assoc-value
(
context-system-releases
out-context
)
(
system-release-release
sr
))))
out-context
)))
clpm/update.lisp
View file @
79c65603
...
...
@@ -27,10 +27,11 @@
(
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
))
(
when-let*
((
release-cons
(
find-if
(
lambda
(
x
)
(
member
system
x
:test
#'
equal
))
(
context-system-releases
orig-context
)
:key
#'
cdr
))
(
release
(
car
release-cons
))
(
project-name
(
project-name
(
release-project
release
))))
(
pushnew
project-name
update-projects
:test
#'
equal
)))
...
...
Eric Timmons
@etimmons
mentioned in commit
1af0a3c3
·
May 31, 2020
mentioned in commit
1af0a3c3
mentioned in commit 1af0a3c3f15ae5186338ed9d585f867c9d8b57f3
Toggle commit list
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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