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
ebf9cdf6
Commit
ebf9cdf6
authored
Sep 03, 2021
by
Eric Timmons
Browse files
Create multiple VCS-SOURCEs per context
parent
96cb639f
Pipeline
#4591
passed with stages
in 29 minutes and 33 seconds
Changes
7
Pipelines
2
Hide whitespace changes
Inline
Side-by-side
clpm/bundle.lisp
View file @
ebf9cdf6
...
...
@@ -62,7 +62,8 @@ the lock file if necessary."
;; from the clpmfile.
(
setf
(
context-requirements
lockfile
)
nil
)
(
setf
(
context-user-sources
lockfile
)
(
context-user-sources
clpmfile
)
(
context-fs-sources-ht
lockfile
)
(
context-fs-sources-ht
clpmfile
))
(
context-fs-sources-ht
lockfile
)
(
context-fs-sources-ht
clpmfile
)
(
context-vcs-sources-ht
lockfile
)
(
context-vcs-sources-ht
clpmfile
))
(
setf
lockfile
(
install-requirements
(
context-requirements
clpmfile
)
:context
lockfile
:validate
validate
...
...
@@ -96,7 +97,9 @@ the lock file if necessary."
;; Nuke the lockfile's requirements so that we pick up deletions
;; from the clpmfile.
(
setf
(
context-requirements
lockfile
)
nil
)
(
setf
(
context-user-sources
lockfile
)
(
context-user-sources
clpmfile
))
(
setf
(
context-user-sources
lockfile
)
(
context-user-sources
clpmfile
)
(
context-fs-sources-ht
lockfile
)
(
context-fs-sources-ht
clpmfile
)
(
context-vcs-sources-ht
lockfile
)
(
context-vcs-sources-ht
clpmfile
))
(
install-requirements
(
context-requirements
clpmfile
)
:context
lockfile
:validate
validate
...
...
clpm/clpmfile.lisp
View file @
ebf9cdf6
...
...
@@ -111,10 +111,12 @@ source."
instance."
(
destructuring-bind
(
name
&key
(
host
"github.com"
)
path
branch
commit
tag
systems
)
args
(
let
((
source
(
context-vcs-source
clpmfile
))
(
repo
(
make-repo-from-description
(
list
:github
:host
host
:path
path
))))
;; Register the git project.
(
vcs-source-register-project!
source
repo
name
)
(
let*
((
repo-description
(
list
:github
:host
host
:path
path
))
(
repo
(
make-repo-from-description
repo-description
))
(
vcs-sources-ht
(
context-vcs-sources-ht
clpmfile
))
(
source
(
ensure-gethash
(
repo-to-form
repo
)
vcs-sources-ht
(
make-source
'vcs-source
:repo
repo-description
:project-name
name
))))
(
assert
(
xor
branch
commit
tag
))
(
push
(
make-instance
'vcs-project-requirement
:systems
systems
...
...
@@ -132,10 +134,12 @@ instance."
instance."
(
destructuring-bind
(
name
&key
(
host
"gitlab.com"
)
path
branch
commit
tag
systems
)
args
(
let
((
source
(
context-vcs-source
clpmfile
))
(
repo
(
make-repo-from-description
(
list
:gitlab
:host
host
:path
path
))))
;; Register the git project.
(
vcs-source-register-project!
source
repo
name
)
(
let*
((
repo-description
(
list
:gitlab
:host
host
:path
path
))
(
repo
(
make-repo-from-description
repo-description
))
(
vcs-sources-ht
(
context-vcs-sources-ht
clpmfile
))
(
source
(
ensure-gethash
(
repo-to-form
repo
)
vcs-sources-ht
(
make-source
'vcs-source
:repo
repo-description
:project-name
name
))))
(
assert
(
xor
branch
commit
tag
))
(
push
(
make-instance
'vcs-project-requirement
:systems
systems
...
...
clpm/context.lisp
View file @
ebf9cdf6
...
...
@@ -37,7 +37,8 @@
#:context-to-asdf-source-registry-form
#:context-to-asdf-source-registry.d-forms
#:context-user-sources
#:context-vcs-source
#:context-vcs-sources
#:context-vcs-sources-ht
#:context-visible-primary-system-names
#:context-write-asdf-files
#:copy-context
...
...
@@ -67,10 +68,12 @@ pathname (if this is an anonymous context).")
:accessor
context-fs-sources-ht
:documentation
"The implicit filesystem sources rooted for this context."
)
(
vcs-source
:accessor
context-vcs-source
(
vcs-sources-ht
:initarg
:vcs-sources-ht
:initform
(
make-hash-table
:test
'equal
)
:accessor
context-vcs-sources-ht
:documentation
"
A VCS source to where raw vcs requirements can be homed
."
)
"
The implicit VCS sources rooted for this context
."
)
(
user-sources
:initform
nil
:initarg
:user-sources
...
...
@@ -97,13 +100,12 @@ pathname (if this is an anonymous context).")
in the context, the requirements that gave rise to those releases, etc. Contexts
can be named, global contexts, or anonymous."
))
(
defmethod
initialize-instance
:after
((
context
context
)
&key
&allow-other-keys
)
(
setf
(
context-vcs-source
context
)
(
make-source
'vcs-source
:name
:implicit-vcs
)))
(
defmethod
context-fs-sources
((
context
context
))
(
hash-table-values
(
context-fs-sources-ht
context
)))
(
defmethod
context-vcs-sources
((
context
context
))
(
hash-table-values
(
context-vcs-sources-ht
context
)))
(
defgeneric
context-name
(
context
))
(
defmethod
context-name
((
context
pathname
))
...
...
@@ -137,6 +139,7 @@ can be named, global contexts, or anonymous."))
:reverse-dependencies
(
copy-alist
(
context-reverse-dependencies
context
))
:user-sources
(
copy-list
(
context-user-sources
context
))
:fs-sources-ht
(
copy-hash-table
(
context-fs-sources-ht
context
))
:vcs-sources-ht
(
copy-hash-table
(
context-vcs-sources-ht
context
))
:system-releases
(
copy-tree
(
context-system-releases
context
))))
(
defun
global-context-pathname
(
name
)
...
...
@@ -158,7 +161,7 @@ can be named, global contexts, or anonymous."))
(
defun
context-sources
(
context
)
(
append
(
context-fs-sources
context
)
(
list
(
context-vcs-source
context
)
)
(
context-vcs-source
s
context
)
(
context-user-sources
context
)))
(
defun
make-vcs-override-fun
(
root-pathname
)
...
...
@@ -428,7 +431,8 @@ in place with the same name. Return the new requirement if it was modified."
((
or
branch
tag
commit
ref
)
(
make-instance
'vcs-project-requirement
:name
name
:source
(
get-source
source
)
:source
(
when
(
eql
source
:implicit-vcs
)
(
get-vcs-source-for-project
name
))
:commit
commit
:branch
branch
:tag
tag
...
...
@@ -447,9 +451,13 @@ in place with the same name. Return the new requirement if it was modified."
(
defmethod
process-form
(
context
(
section
(
eql
:releases
))
form
)
(
destructuring-bind
(
name
&key
version
source
systems
)
form
(
let*
((
source
(
if
(
eql
source
:implicit-file
)
(
get-source
name
)
(
get-source
source
)))
(
let*
((
source
(
cond
((
eql
source
:implicit-file
)
(
get-source
name
))
((
eql
source
:implicit-vcs
)
(
get-vcs-source-for-project
name
))
(
t
(
get-source
source
))))
(
release
(
source-project-release
source
name
version
)))
(
push
release
(
context-releases
context
))
...
...
@@ -463,9 +471,13 @@ in place with the same name. Return the new requirement if it was modified."
(
case
(
first
form
)
(
:implicit-vcs
(
dolist
(
project-description
(
getf
(
rest
form
)
:projects
))
(
vcs-source-register-project!
(
context-vcs-source
context
)
(
make-repo-from-description
(
rest
project-description
))
(
first
project-description
))))
(
let*
((
project-name
(
car
project-description
))
(
repo-description
(
cdr
project-description
))
(
repo
(
make-repo-from-description
repo-description
)))
(
ensure-gethash
(
repo-to-form
repo
)
(
context-vcs-sources-ht
context
)
(
make-source
'vcs-source
:repo
repo-description
:project-name
project-name
)))))
(
:implicit-file
(
dolist
(
sf
(
getf
(
rest
form
)
:system-files
))
(
ensure-gethash
sf
(
context-fs-sources-ht
context
)
...
...
@@ -545,17 +557,6 @@ in place with the same name. Return the new requirement if it was modified."
(
format
stream
":sources~%"
)
(
dolist
(
source
(
context-sources
context
))
(
let
((
form
(
source-to-form
source
)))
(
when
(
typep
source
'vcs-source
)
;; Strip out the projects that aren't installed
(
setf
(
getf
(
rest
form
)
:projects
)
(
remove-if-not
(
lambda
(
x
)
(
when-let
((
release
(
find
x
(
context-releases
context
)
:test
#'
equal
:key
(
compose
#'
project-name
#'
release-project
))))
(
equal
source
(
release-source
release
))))
(
getf
(
rest
form
)
:projects
)
:key
#'
car
)))
(
format
stream
"~S~%"
form
)))
(
terpri
stream
)
(
terpri
stream
)
...
...
@@ -606,10 +607,14 @@ in place with the same name. Return the new requirement if it was modified."
`
(
,
(
project-name
(
release-project
release
))
:version
,
(
release-version
release
)
;; TODO: Bundle v0.4 maybe replace with the .asd pathname instead of
;; :IMPLICIT-FILE?
:source
,
(
if
(
typep
(
release-source
release
)
'fs-source
)
:implicit-file
(
source-name
(
release-source
release
)))
;; :IMPLICIT-FILE? Same with :IMPLICIT-VCS.
:source
,
(
typecase
(
release-source
release
)
(
fs-source
:implicit-file
)
(
vcs-source
:implicit-vcs
)
(
t
(
source-name
(
release-source
release
))))
:systems
,
(
safe-sort
system-names
#'
string<
)))
(
defun
context-reverse-deps-to-form
(
release-and-reverse-deps
)
...
...
clpm/requirement.lisp
View file @
ebf9cdf6
...
...
@@ -205,15 +205,24 @@ represents."))
(
defgeneric
requirement-to-plist
(
req
))
;; TODO: context version 0.4, get rid of :implicit-vcs.
(
defun
backward-compatible-source-name
(
source
)
(
typecase
source
(
clpm-source
;; HACK to avoid circular dep.
(
if
(
string-equal
'vcs-source
(
class-name
(
class-of
source
)))
:implicit-vcs
(
source-name
source
)))
(
t
source
)))
(
defmethod
requirement-to-plist
((
req
versioned-requirement
))
(
append
(
list
:name
(
requirement-name
req
))
(
awhen
(
requirement-version-spec
req
)
(
list
:version
it
))
(
awhen
(
requirement-source
req
)
(
list
:source
(
if
(
typep
it
'clpm-source
)
(
source-name
it
)
it
)))
(
list
:source
(
backward-compatible-source-name
it
)))
(
awhen
(
requirement-no-deps-p
req
)
(
list
:no-deps-p
it
))))
...
...
@@ -229,9 +238,7 @@ represents."))
(
awhen
(
requirement-ref
req
)
(
list
:ref
it
))
(
awhen
(
requirement-source
req
)
(
list
:source
(
if
(
typep
it
'clpm-source
)
(
source-name
it
)
it
)))
(
list
:source
(
backward-compatible-source-name
it
)))
(
awhen
(
requirement-no-deps-p
req
)
(
list
:no-deps-p
it
))))
...
...
clpm/resolve.lisp
View file @
ebf9cdf6
...
...
@@ -101,7 +101,7 @@
set of installed releases is updated to be the minimum set that satisfies all
the requirements."
(
with-sources
((
context-sources
context
))
(
vcs-source-clear-visible-releases
(
context-vcs-source
context
))
(
mapc
#'
vcs-source-clear-visible-releases
(
context-vcs-source
s
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
))
...
...
clpm/source.lisp
View file @
ebf9cdf6
...
...
@@ -17,6 +17,7 @@
(
:reexport
#:clpm/sources/fs
)
(
:reexport
#:clpm/sources/vcs
)
(
:export
#:get-source
#:get-vcs-source-for-project
#:sources
#:with-sources
))
...
...
@@ -44,6 +45,14 @@
(
error
"Unable to find source named ~S"
source-designator
))
source
))))
(
defun
get-vcs-source-for-project
(
project-name
&optional
(
errorp
t
))
(
or
(
loop
:for
vcs-source
:in
(
remove-if-not
(
lambda
(
x
)
(
typep
x
'vcs-source
))
(
sources
))
:when
(
equal
project-name
(
project-name
(
vcs-source-project
vcs-source
)))
:do
(
return
vcs-source
))
(
when
errorp
(
error
"Unable to find VCS source for project ~S"
project-name
))))
(
defun
call-with-sources
(
sources
thunk
)
(
let
((
*visible-sources*
sources
))
(
funcall
thunk
)))
...
...
clpm/sources/vcs.lisp
View file @
ebf9cdf6
...
...
@@ -30,7 +30,7 @@
#:vcs-remote-release
#:vcs-source
#:vcs-source-clear-visible-releases
#:vcs-source-
register-
project
!
#:vcs-source-project
#:vcs-system
))
(
in-package
#:clpm/sources/vcs
)
...
...
@@ -44,10 +44,12 @@
((
name
:initarg
:name
:reader
source-name
)
(
projects-by-name
:initform
(
make-hash-table
:test
'equal
)
:accessor
vcs-source-projects-by-name
:documentation
"hash table mapping project names to project objects."
)
(
repo
:initarg
:repo
:reader
vcs-source-repo
)
(
project
:accessor
vcs-source-project
:documentation
"The single project for the source."
)
(
systems-by-name
:initform
(
make-hash-table
:test
'equalp
)
:accessor
vcs-source-systems-by-name
...
...
@@ -56,38 +58,22 @@
"A source for any bare VCS projects. Projects must be registered with the
source using VCS-SOURCE-REGISTER_PROJECT!."
))
(
defmethod
make-source
((
type
(
eql
'vcs-source
))
&rest
initargs
&key
name
projects
)
(
with-clpm-session
(
:key
`
(
make-source
,
type
,
name
))
(
aprog1
(
apply
#'
make-instance
type
initargs
)
(
dolist
(
project
projects
)
(
destructuring-bind
(
project-name
.
repo-form
)
project
(
vcs-source-register-project!
it
(
make-repo-from-description
repo-form
)
project-name
))))))
(
defmethod
initialize-instance
:after
((
source
vcs-source
)
&rest
initargs
&key
projects
&allow-other-keys
)
(
declare
(
ignore
initargs
))
(
dolist
(
project
projects
)
(
destructuring-bind
(
project-name
.
repo-form
)
project
(
vcs-source-register-project!
source
(
make-repo-from-description
repo-form
)
project-name
))))
(
defmethod
make-source
((
type
(
eql
'vcs-source
))
&key
repo
project-name
)
(
let*
((
repo-object
(
make-repo-from-description
repo
))
(
name
(
repo-to-form
repo-object
)))
(
format
t
"~S~%"
project-name
)
(
with-clpm-session
(
:key
`
(
make-source
,
type
,
name
))
(
make-instance
type
:name
name
:project-name
project-name
:repo
repo-object
))))
(
defmethod
initialize-instance
:after
((
source
vcs-source
)
&key
project-name
)
(
setf
(
vcs-source-project
source
)
(
make-instance
'vcs-project
:source
source
:name
project-name
)))
(
defun
vcs-source-clear-visible-releases
(
vcs-source
)
(
maphash
(
lambda
(
k
v
)
(
declare
(
ignore
k
))
(
setf
(
vcs-project-visible-releases
v
)
nil
))
(
vcs-source-projects-by-name
vcs-source
)))
(
defun
vcs-source-register-project!
(
vcs-source
repo
project-name
)
"Registers a project with the vcs source and returns it."
(
let
((
projects-by-name
(
vcs-source-projects-by-name
vcs-source
)))
(
ensure-gethash
project-name
projects-by-name
(
make-instance
'vcs-project
:repo
repo
:source
vcs-source
:name
project-name
))))
(
setf
(
vcs-project-visible-releases
(
vcs-source-project
vcs-source
))
nil
))
(
defmethod
source-ensure-system
((
source
vcs-source
)
system-name
)
(
ensure-gethash
...
...
@@ -100,7 +86,8 @@ source using VCS-SOURCE-REGISTER_PROJECT!."))
t
)
(
defmethod
source-project
((
source
vcs-source
)
project-name
&optional
(
error
t
))
(
or
(
gethash
project-name
(
vcs-source-projects-by-name
source
))
(
if
(
equal
project-name
(
project-name
(
vcs-source-project
source
)))
(
vcs-source-project
source
)
(
when
error
(
error
'source-missing-project
:source
source
...
...
@@ -108,27 +95,20 @@ source using VCS-SOURCE-REGISTER_PROJECT!."))
(
defmethod
source-system
((
source
vcs-source
)
system-name
&optional
(
error
t
))
(
or
(
gethash
system-name
(
vcs-source-systems-by-name
source
))
(
some
(
lambda
(
project
)
(
some
(
lambda
(
release
)
(
when-let
((
system-release
(
release-system-release
release
system-name
nil
)))
(
system-release-system
system-release
)))
(
project-releases
project
)))
(
hash-table-values
(
vcs-source-projects-by-name
source
)))
(
some
(
lambda
(
release
)
(
when-let
((
system-release
(
release-system-release
release
system-name
nil
)))
(
system-release-system
system-release
)))
(
project-releases
(
vcs-source-project
source
)))
(
when
error
(
error
'source-missing-system
:source
source
:system-name
system-name
))))
(
defmethod
source-to-form
((
source
vcs-source
))
(
let
((
projects
nil
))
(
maphash
(
lambda
(
project-name
project
)
(
push
(
cons
project-name
(
repo-to-form
(
project-repo
project
)))
projects
))
(
vcs-source-projects-by-name
source
))
(
list
(
source-name
source
)
:type
:vcs
:projects
(
safe-sort
projects
#'
string<
:key
#'
car
))))
(
let
((
project
(
vcs-source-project
source
)))
`
(
:implicit-vcs
:type
:vcs
:projects
((
,
(
project-name
project
)
.
,
(
repo-to-form
(
project-repo
project
)))))))
(
defmethod
sync-source
((
source
vcs-source
))
nil
)
...
...
@@ -168,9 +148,6 @@ local override when requesting a VCS release.")
(
name
:initarg
:name
:reader
project-name
)
(
repo
:initarg
:repo
:reader
project-repo
)
(
visible-releases
:initform
nil
:accessor
vcs-project-visible-releases
)
...
...
@@ -178,6 +155,9 @@ local override when requesting a VCS release.")
:initform
(
make-hash-table
:test
'equal
)
:accessor
vcs-project-releases-by-spec
)))
(
defmethod
project-repo
((
project
vcs-project
))
(
vcs-source-repo
(
project-source
project
)))
(
defmethod
project-releases
((
project
vcs-project
))
(
vcs-project-visible-releases
project
))
...
...
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