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
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."
...
@@ -85,10 +85,11 @@ the lock file if necessary."
(
sync-source
s
))))
(
sync-source
s
))))
;; Map all update systems to their projects.
;; Map all update systems to their projects.
(
dolist
(
system
update-systems
)
(
dolist
(
system
update-systems
)
(
when-let*
((
system-release
(
find
system
(
context-system-releases
lockfile
)
(
when-let*
((
release-cons
(
find-if
(
lambda
(
x
)
:key
(
compose
#'
system-name
#'
system-release-system
)
(
member
system
x
:test
#'
equal
))
:test
#'
equal
))
(
context-system-releases
lockfile
)
(
release
(
system-release-release
system-release
))
:key
#'
cdr
))
(
release
(
car
release-cons
))
(
project-name
(
project-name
(
release-project
release
))))
(
project-name
(
project-name
(
release-project
release
))))
(
pushnew
project-name
update-projects
:test
#'
equal
)))
(
pushnew
project-name
update-projects
:test
#'
equal
)))
;; Nuke the lockfile's requirements so that we pick up deletions
;; Nuke the lockfile's requirements so that we pick up deletions
...
...
clpm/clpi.lisp
View file @
79c65603
...
@@ -76,10 +76,13 @@
...
@@ -76,10 +76,13 @@
(
let*
((
missing-system-spec
(
groveler-dependency-missing-system
c
))
(
let*
((
missing-system-spec
(
groveler-dependency-missing-system
c
))
(
missing-req
(
convert-asd-system-spec-to-req
missing-system-spec
))
(
missing-req
(
convert-asd-system-spec-to-req
missing-system-spec
))
(
missing-system-name
(
requirement-name
missing-req
))
(
missing-system-name
(
requirement-name
missing-req
))
(
matching-sr
(
find
missing-system-name
(
matching-cons
(
find-if
(
lambda
(
x
)
(
context-system-releases
clpmfile
)
(
member
missing-system-name
x
:test
#'
equal
))
:test
#'
equal
(
context-system-releases
clpmfile
)
:key
(
compose
#'
system-name
#'
system-release-system
))))
:key
#'
cdr
))
(
matching-sr
(
when
matching-cons
(
release-system-release
(
car
matching-cons
)
missing-system-name
))))
(
when
(
and
matching-sr
(
when
(
and
matching-sr
(
system-release-satisfies-version-spec-p
(
system-release-satisfies-version-spec-p
matching-sr
matching-sr
...
...
clpm/context.lisp
View file @
79c65603
...
@@ -83,7 +83,12 @@ pathname (if this is an anonymous context).")
...
@@ -83,7 +83,12 @@ pathname (if this is an anonymous context).")
(
system-releases
(
system-releases
:initform
nil
:initform
nil
:initarg
:system-releases
: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
(
:documentation
"Represents a snapshot of a context. Includes sources, the releases installed
"Represents a snapshot of a context. Includes sources, the releases installed
in the context, the requirements that gave rise to those releases, etc. Contexts
in the context, the requirements that gave rise to those releases, etc. Contexts
...
@@ -128,7 +133,7 @@ can be named, global contexts, or anonymous."))
...
@@ -128,7 +133,7 @@ can be named, global contexts, or anonymous."))
:requirements
(
copy-list
(
context-requirements
context
))
:requirements
(
copy-list
(
context-requirements
context
))
:reverse-dependencies
(
copy-alist
(
context-reverse-dependencies
context
))
:reverse-dependencies
(
copy-alist
(
context-reverse-dependencies
context
))
:user-sources
(
copy-list
(
context-user-sources
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
)
(
defun
global-context-pathname
(
name
)
(
clpm-data-pathname
(
list
"contexts"
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."
...
@@ -229,18 +234,24 @@ in place with the same name. Return the new requirement if it was modified."
(
let*
((
context
(
get-context
context
))
(
let*
((
context
(
get-context
context
))
(
system-releases
(
context-system-releases
context
)))
(
system-releases
(
context-system-releases
context
)))
(
remove-duplicates
(
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
)))
:test
#'
equal
)))
(
defun
context-installed-systems
(
context
)
(
defun
context-installed-systems
(
context
)
(
let*
((
context
(
get-context
context
))
(
let*
((
context
(
get-context
context
))
(
system-releases
(
context-system-releases
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
)
(
defun
context-visible-primary-system-names
(
context
)
(
let*
((
context
(
get-context
context
))
(
let*
((
context
(
get-context
context
))
(
releases
(
context-releases
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-files
(
remove-duplicates
(
mapcar
#'
system-release-system-file
system-releases
)))
(
system-file-directories
(
remove-duplicates
(
mapcar
(
compose
#'
uiop:pathname-directory-pathname
(
system-file-directories
(
remove-duplicates
(
mapcar
(
compose
#'
uiop:pathname-directory-pathname
#'
system-file-absolute-asd-pathname
)
#'
system-file-absolute-asd-pathname
)
...
@@ -283,9 +294,11 @@ in place with the same name. Return the new requirement if it was modified."
...
@@ -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
)
(
defun
context-find-system-asd-pathname
(
context
system-name
)
(
when-let*
((
context
(
get-context
context
))
(
when-let*
((
context
(
get-context
context
))
(
system-release
(
find
system-name
(
context-system-releases
context
)
(
system-release-cons
(
find-if
(
lambda
(
x
)
:key
(
compose
#'
system-name
#'
system-release-system
)
(
member
system-name
x
:test
'equal
))
: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
)))
(
system-release-absolute-asd-pathname
system-release
)))
(
defun
context-write-asdf-files
(
context
)
(
defun
context-write-asdf-files
(
context
)
...
@@ -433,8 +446,8 @@ in place with the same name. Return the new requirement if it was modified."
...
@@ -433,8 +446,8 @@ in place with the same name. Return the new requirement if it was modified."
(
push
release
(
push
release
(
context-releases
context
))
(
context-releases
context
))
(
dolist
(
system-name
systems
)
(
dolist
(
system-name
systems
)
(
push
(
release-system-release
release
system-name
)
(
push
system-name
(
context-system-releases
context
))))))
(
assoc-value
(
context-system-releases
context
)
release
)
)))))
(
defmethod
process-form
(
context
(
section
(
eql
:reverse-dependencies
))
form
))
(
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."
...
@@ -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<
(
dolist
(
release
(
sort
(
copy-list
(
context-releases
context
))
#'
string<
:key
(
compose
#'
project-name
#'
release-project
)))
:key
(
compose
#'
project-name
#'
release-project
)))
(
format
stream
"~S~%"
(
format
stream
"~S~%"
(
context-release-to-form
release
(
remove-if-not
(
lambda
(
x
)
(
context-release-to-form
release
(
assoc-value
(
context-system-releases
context
)
(
eql
x
release
))
release
))))
(
context-system-releases
context
)
:key
#'
system-release-release
))))
(
terpri
stream
)
(
terpri
stream
)
(
terpri
stream
)
(
terpri
stream
)
...
@@ -570,11 +581,11 @@ in place with the same name. Return the new requirement if it was modified."
...
@@ -570,11 +581,11 @@ in place with the same name. Return the new requirement if it was modified."
,
(
list*
(
requirement-type-keyword
req
)
,
(
list*
(
requirement-type-keyword
req
)
(
requirement-to-plist
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
))
`
(
,
(
project-name
(
release-project
release
))
:version
,
(
release-version
release
)
:version
,
(
release-version
release
)
:source
,
(
source-name
(
release-source
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
)
(
defun
context-reverse-deps-to-form
(
release-and-reverse-deps
)
(
destructuring-bind
(
release
.
reverse-deps
)
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."
...
@@ -114,5 +114,8 @@ the requirements."
(
setf
(
context-reverse-dependencies
out-context
)
(
setf
(
context-reverse-dependencies
out-context
)
(
sort
(
copy-alist
(
node-activated-releases
final-node
))
(
sort
(
copy-alist
(
node-activated-releases
final-node
))
#'
string<
:key
(
compose
#'
project-name
#'
release-project
#'
car
)))
#'
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
)))
out-context
)))
clpm/update.lisp
View file @
79c65603
...
@@ -27,10 +27,11 @@
...
@@ -27,10 +27,11 @@
(
with-context
(
context
(
copy-context
orig-context
))
(
with-context
(
context
(
copy-context
orig-context
))
;; Map all systems to their corresponding projects.
;; Map all systems to their corresponding projects.
(
dolist
(
system
update-systems
)
(
dolist
(
system
update-systems
)
(
when-let*
((
system-release
(
find
system
(
context-system-releases
orig-context
)
(
when-let*
((
release-cons
(
find-if
(
lambda
(
x
)
:key
(
compose
#'
system-name
#'
system-release-system
)
(
member
system
x
:test
#'
equal
))
:test
#'
equal
))
(
context-system-releases
orig-context
)
(
release
(
system-release-release
system-release
))
:key
#'
cdr
))
(
release
(
car
release-cons
))
(
project-name
(
project-name
(
release-project
release
))))
(
project-name
(
project-name
(
release-project
release
))))
(
pushnew
project-name
update-projects
:test
#'
equal
)))
(
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
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