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
1d3220e1
Commit
1d3220e1
authored
Feb 23, 2020
by
Eric Timmons
Browse files
Remove slashes from requirement accessors
parent
8fc982d9
Changes
5
Hide whitespace changes
Inline
Side-by-side
src/clpm/context.lisp
View file @
1d3220e1
...
...
@@ -101,14 +101,14 @@
(
typep
req
'vcs-project-requirement
)))
(
:system
(
typep
req
'system-requirement
))
(
:asd-system
(
typep
req
'fs-system-requirement
)))
(
equal
name
(
requirement
/
name
req
))))
(
equal
name
(
requirement
-
name
req
))))
(
context-requirements
context
)))
(
defun
context-add-requirement!
(
context
req
)
"If the requirement is new, add it. Otherwise modify an existing requirement
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
))))
(
requirement
-
name
req
))))
(
if
existing-req
(
progn
(
log:debug
"Replacing requirement ~A with ~A"
existing-req
req
)
...
...
@@ -571,7 +571,7 @@ in place with the same name. Return the new requirement if it was modified."
t
)
(
defun
serialize-reverse-dep
(
req
stream
)
(
let
((
why
(
requirement
/
why
req
)))
(
let
((
why
(
requirement
-
why
req
)))
(
pprint-logical-block
(
stream
nil
:prefix
"("
:suffix
")"
)
(
prin1
(
extract-why
why
)
stream
)
(
pprint-newline
:mandatory
stream
)
...
...
@@ -625,11 +625,11 @@ in place with the same name. Return the new requirement if it was modified."
;; ASD file into the groveler). We can ignore it because we'll
;; have the true reason elsewhere in the list.
(
unless
(
or
(
eql
t
req
)
(
eql
(
requirement
/
why
req
)
:grovel
))
(
eql
(
requirement
-
why
req
)
:grovel
))
(
serialize-reverse-dep
req
stream
))
(
pprint-exit-if-list-exhausted
)
(
unless
(
or
(
eql
t
req
)
(
eql
(
requirement
/
why
req
)
:grovel
))
(
eql
(
requirement
-
why
req
)
:grovel
))
(
pprint-newline
:mandatory
stream
)))))))))
;; ** Requirements
...
...
@@ -659,41 +659,41 @@ in place with the same name. Return the new requirement if it was modified."
(
prin1
:name
stream
)
(
write-char
#\Space
stream
)
(
pprint-newline
:miser
stream
)
(
prin1
(
requirement
/
name
req
)
stream
)
(
prin1
(
requirement
-
name
req
)
stream
)
;; Branch
(
when
(
requirement
/
branch
req
)
(
when
(
requirement
-
branch
req
)
(
write-char
#\Space
stream
)
(
pprint-newline
:fill
stream
)
(
prin1
:branch
stream
)
(
write-char
#\Space
stream
)
(
pprint-newline
:miser
stream
)
(
prin1
(
requirement
/
branch
req
)
stream
))
(
prin1
(
requirement
-
branch
req
)
stream
))
;; Commit
(
when
(
requirement
/
commit
req
)
(
when
(
requirement
-
commit
req
)
(
write-char
#\Space
stream
)
(
pprint-newline
:fill
stream
)
(
prin1
:commit
stream
)
(
write-char
#\Space
stream
)
(
pprint-newline
:miser
stream
)
(
prin1
(
requirement
/
commit
req
)
stream
))
(
prin1
(
requirement
-
commit
req
)
stream
))
;; Tag
(
when
(
requirement
/
tag
req
)
(
when
(
requirement
-
tag
req
)
(
write-char
#\Space
stream
)
(
pprint-newline
:fill
stream
)
(
prin1
:tag
stream
)
(
write-char
#\Space
stream
)
(
pprint-newline
:miser
stream
)
(
prin1
(
requirement
/
tag
req
)
stream
))
(
prin1
(
requirement
-
tag
req
)
stream
))
;; Source
(
when
(
requirement
/
source
req
)
(
when
(
requirement
-
source
req
)
(
write-char
#\Space
stream
)
(
pprint-newline
:fill
stream
)
(
prin1
:source
stream
)
(
write-char
#\Space
stream
)
(
pprint-newline
:miser
stream
)
(
prin1
(
source-name
(
requirement
/
source
req
))
stream
))
(
prin1
(
source-name
(
requirement
-
source
req
))
stream
))
;; no deps
(
when
(
requirement
/
no-deps-p
req
)
(
when
(
requirement
-
no-deps-p
req
)
(
write-char
#\Space
stream
)
(
pprint-newline
:fill
stream
)
(
prin1
:no-deps-p
stream
)
...
...
@@ -709,25 +709,25 @@ in place with the same name. Return the new requirement if it was modified."
(
prin1
:name
stream
)
(
write-char
#\Space
stream
)
(
pprint-newline
:miser
stream
)
(
prin1
(
requirement
/
name
req
)
stream
)
(
prin1
(
requirement
-
name
req
)
stream
)
;; Version
(
when
(
requirement
/
version-spec
req
)
(
when
(
requirement
-
version-spec
req
)
(
write-char
#\Space
stream
)
(
pprint-newline
:fill
stream
)
(
prin1
:version
stream
)
(
write-char
#\Space
stream
)
(
pprint-newline
:miser
stream
)
(
prin1
(
requirement
/
version-spec
req
)
stream
))
(
prin1
(
requirement
-
version-spec
req
)
stream
))
;; Source
(
when
(
requirement
/
source
req
)
(
when
(
requirement
-
source
req
)
(
write-char
#\Space
stream
)
(
pprint-newline
:fill
stream
)
(
prin1
:source
stream
)
(
write-char
#\Space
stream
)
(
pprint-newline
:miser
stream
)
(
prin1
(
source-name
(
requirement
/
source
req
))
stream
))
(
prin1
(
source-name
(
requirement
-
source
req
))
stream
))
;; no deps
(
when
(
requirement
/
no-deps-p
req
)
(
when
(
requirement
-
no-deps-p
req
)
(
write-char
#\Space
stream
)
(
pprint-newline
:fill
stream
)
(
prin1
:no-deps-p
stream
)
...
...
@@ -742,16 +742,16 @@ in place with the same name. Return the new requirement if it was modified."
(
pprint-newline
:fill
stream
)
(
prin1
:pathname
stream
)
(
write-char
#\Space
stream
)
(
prin1
(
requirement
/
pathname
req
)
stream
)
(
prin1
(
requirement
-
pathname
req
)
stream
)
;; Name
(
write-char
#\Space
stream
)
(
pprint-newline
:fill
stream
)
(
prin1
:name
stream
)
(
write-char
#\Space
stream
)
(
pprint-newline
:miser
stream
)
(
prin1
(
requirement
/
name
req
)
stream
)
(
prin1
(
requirement
-
name
req
)
stream
)
;; no deps
(
when
(
requirement
/
no-deps-p
req
)
(
when
(
requirement
-
no-deps-p
req
)
(
write-char
#\Space
stream
)
(
pprint-newline
:fill
stream
)
(
prin1
:no-deps-p
stream
)
...
...
src/clpm/requirement.lisp
View file @
1d3220e1
...
...
@@ -10,18 +10,18 @@
#:fs-system-file-requirement
#:fs-system-requirement
#:project-requirement
#:requirement
/
branch
#:requirement
/
commit
#:requirement
/
name
#:requirement
/
no-deps-p
#:requirement
/
pathname
#:requirement
/
repo
#:requirement
/
source
#:requirement
/
systems
#:requirement
/
system-files
#:requirement
/
tag
#:requirement
/
version-spec
#:requirement
/
why
#:requirement
-
branch
#:requirement
-
commit
#:requirement
-
name
#:requirement
-
no-deps-p
#:requirement
-
pathname
#:requirement
-
repo
#:requirement
-
source
#:requirement
-
systems
#:requirement
-
system-files
#:requirement
-
tag
#:requirement
-
version-spec
#:requirement
-
why
#:system-requirement
#:vcs-project-requirement
#:vcs-requirement
...
...
@@ -32,27 +32,27 @@
(
defclass
requirement
()
((
name
:initarg
:name
:reader
requirement
/
name
:reader
requirement
-
name
:documentation
"The name of the thing being required. Typically a string, but may be other
objects (like pathnames)."
)
(
source
:initarg
:source
:initform
nil
:accessor
requirement
/
source
:accessor
requirement
-
source
:documentation
"If non-NIL, the requirement must be satisfied using releases provided by
this source."
)
(
no-deps-p
:initarg
:no-deps-p
:initform
nil
:accessor
requirement
/
no-deps-p
:accessor
requirement
-
no-deps-p
:documentation
"If non-NIL, the requirement's dependencies do not need to be satisfied."
)
(
why
:initarg
:why
:initform
nil
:accessor
requirement
/
why
:accessor
requirement
-
why
:documentation
"The reason this requirement was generated."
))
(
:documentation
...
...
@@ -62,7 +62,7 @@ this source.")
((
version-spec
:initarg
:version-spec
:initform
nil
:accessor
requirement
/
version-spec
:accessor
requirement
-
version-spec
:documentation
"The version specifier that must be satisfied."
))
(
:documentation
...
...
@@ -72,25 +72,25 @@ this source.")
((
repo
:initarg
:repo
:initform
nil
:reader
requirement
/
repo
:reader
requirement
-
repo
:documentation
"The repo object describing the upstream repo for this requirement."
)
(
branch
:initarg
:branch
:initform
nil
:reader
requirement
/
branch
:reader
requirement
-
branch
:documentation
"If non-NIL, string naming the required branch."
)
(
commit
:initarg
:commit
:initform
nil
:reader
requirement
/
commit
:reader
requirement
-
commit
:documentation
"If non-NIL, string naming the required commit."
)
(
tag
:initarg
:tag
:initform
nil
:reader
requirement
/
tag
:reader
requirement
-
tag
:documentation
"If non-NIL, string naming the required tag."
))
(
:documentation
...
...
@@ -110,13 +110,13 @@ this source.")
((
systems
:initarg
:systems
:initform
nil
:reader
requirement
/
systems
:reader
requirement
-
systems
:documentation
"A list of system names to require."
)
(
system-files
:initarg
:system-files
:initform
nil
:reader
requirement
/
system-files
:reader
requirement
-
system-files
:documentation
"A list of system files to require."
))
(
:documentation
...
...
@@ -130,7 +130,7 @@ in the project."))
(
defclass
fs-system-requirement
(
requirement
)
((
pathname
:initarg
:pathname
:accessor
requirement
/
pathname
:accessor
requirement
-
pathname
:documentation
"The pathname to the asd file containing this system."
))
(
:documentation
...
...
@@ -150,24 +150,24 @@ filesystem must be included. NAME is the pathname to the asd file."))
(
prin1
:name
stream
)
(
write-char
#\Space
stream
)
(
pprint-newline
:miser
stream
)
(
write
(
requirement
/
name
req
)
:stream
stream
)
(
write
(
requirement
-
name
req
)
:stream
stream
)
;; version
(
when
(
and
(
typep
req
'versioned-requirement
)
(
requirement
/
version-spec
req
))
(
requirement
-
version-spec
req
))
(
write-char
#\Space
stream
)
(
pprint-newline
:linear
stream
)
(
prin1
:version
stream
)
(
write-char
#\Space
stream
)
(
pprint-newline
:miser
stream
)
(
write
(
requirement
/
version-spec
req
)
:stream
stream
))
(
write
(
requirement
-
version-spec
req
)
:stream
stream
))
;; why
(
when
(
requirement
/
why
req
)
(
when
(
requirement
-
why
req
)
(
write-char
#\Space
stream
)
(
pprint-newline
:linear
stream
)
(
prin1
:why
stream
)
(
write-char
#\Space
stream
)
(
pprint-newline
:miser
stream
)
(
write
(
requirement
/
why
req
)
:stream
stream
))
(
write
(
requirement
-
why
req
)
:stream
stream
))
;; ID
(
pprint-newline
:linear
stream
))))
...
...
src/clpm/resolve.lisp
View file @
1d3220e1
...
...
@@ -75,15 +75,15 @@
(
defun
rewrite-vcs-req
(
req
context
)
"Given a VCS requirement and a context, "
(
let
((
existing-release
(
find
(
requirement
/
name
req
)
(
context-releases
context
)
(
let
((
existing-release
(
find
(
requirement
-
name
req
)
(
context-releases
context
)
:test
#'
equal
:key
(
compose
#'
project-name
#'
release-project
))))
(
if
(
and
existing-release
(
listp
(
release-version
existing-release
)))
(
progn
(
make-instance
'vcs-project-requirement
:name
(
requirement
/
name
req
)
:source
(
requirement
/
source
req
)
:why
(
requirement
/
why
req
)
:no-deps-p
(
requirement
/
no-deps-p
req
)
:name
(
requirement
-
name
req
)
:source
(
requirement
-
source
req
)
:why
(
requirement
-
why
req
)
:no-deps-p
(
requirement
-
no-deps-p
req
)
:commit
(
second
(
release-version
existing-release
))))
req
)))
...
...
@@ -91,7 +91,7 @@
(
mapcar
(
lambda
(
req
)
(
if
(
and
(
not
(
eql
update-projects
t
))
(
typep
req
'vcs-requirement
)
(
not
(
member
(
requirement
/
name
req
)
update-projects
:test
#'
equal
)))
(
not
(
member
(
requirement
-
name
req
)
update-projects
:test
#'
equal
)))
(
rewrite-vcs-req
req
context
)
req
))
reqs
))
...
...
src/clpm/resolve/requirement.lisp
View file @
1d3220e1
...
...
@@ -45,7 +45,7 @@ source can be found."))
(
defmethod
find-requirement-source
:around
(
req
&optional
(
errorp
t
))
"If the requirement has a specific source set, use that. Otherwise, fallback
to searching."
(
let
((
out
(
or
(
requirement
/
source
req
)
(
let
((
out
(
or
(
requirement
-
source
req
)
(
call-next-method
))))
(
or
out
(
when
errorp
...
...
@@ -55,19 +55,19 @@ to searching."
"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
)))
(
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
by an :AROUND method."
(
declare
(
ignore
errorp
))
(
find-system-source
(
requirement
/
name
req
)))
(
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
handled by an :AROUND method."
(
declare
(
ignore
errorp
))
(
find-project-source
(
requirement
/
name
req
)))
(
find-project-source
(
requirement
-
name
req
)))
;; * Requirement States
...
...
@@ -77,13 +77,13 @@ handled by an :AROUND method."
satisfied. Returns one of :SAT, :UNSAT, or :UNKNOWN."
))
(
defmethod
requirement-state
((
req
fs-system-requirement
)
node
)
(
let*
((
system-name
(
requirement
/
name
req
))
(
let*
((
system-name
(
requirement
-
name
req
))
(
system-release
(
node-find-system-if-active
node
system-name
)))
(
cond
((
not
system-release
)
:unknown
)
((
not
(
eql
(
system-release-source
system-release
)
(
requirement
/
source
req
)))
(
requirement
-
source
req
)))
:unsat
)
(
t
:sat
))))
...
...
@@ -91,8 +91,8 @@ satisfied. Returns one of :SAT, :UNSAT, or :UNKNOWN."))
(
defmethod
requirement-state
((
req
project-requirement
)
node
)
"A project requirement is satisfied if a release for the project is active in
the search node and its version satisfies the requested version."
(
let*
((
project-name
(
requirement
/
name
req
))
(
version-spec
(
requirement
/
version-spec
req
))
(
let*
((
project-name
(
requirement
-
name
req
))
(
version-spec
(
requirement
-
version-spec
req
))
(
release
(
node-find-project-if-active
node
project-name
)))
(
cond
((
not
release
)
...
...
@@ -105,8 +105,8 @@ the search node and its version satisfies the requested version."
(
defmethod
requirement-state
((
req
system-requirement
)
node
)
"A system requirement is satisfied if there is an active system release that
provides the system."
(
let*
((
system-name
(
requirement
/
name
req
))
(
version-spec
(
requirement
/
version-spec
req
))
(
let*
((
system-name
(
requirement
-
name
req
))
(
version-spec
(
requirement
-
version-spec
req
))
(
system-release
(
node-find-system-if-active
node
system-name
)))
(
cond
((
provided-system-p
system-name
)
...
...
@@ -141,8 +141,8 @@ 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
))
(
let*
((
system-name
(
requirement
-
name
req
))
(
fs-source
(
requirement
-
source
req
))
(
system
(
source-system
fs-source
system-name
))
(
releases
(
system-releases
system
))
(
release
(
first
releases
))
...
...
@@ -164,11 +164,11 @@ a plist. This plist can contain :system-releases or :system-files."))
satisfy the version spec (if any) and including every system release per
satisfying release."
(
when-let*
((
project-name
(
requirement
/
name
req
))
((
project-name
(
requirement
-
name
req
))
(
source
(
find-requirement-source
req
nil
))
(
project
(
source-project
source
project-name
))
(
releases
(
project-releases
project
))
(
applicable-releases
(
remove-if-not
(
rcurry
#'
release-satisfies-version-spec-p
(
requirement
/
version-spec
req
))
(
applicable-releases
(
remove-if-not
(
rcurry
#'
release-satisfies-version-spec-p
(
requirement
-
version-spec
req
))
releases
)))
(
mapcar
(
lambda
(
x
)
(
list
x
:system-releases
(
release-system-releases
x
)))
...
...
@@ -177,12 +177,12 @@ satisfying release."
(
defmethod
resolve-requirement
((
req
system-requirement
)
node
)
"A system requirement is resolved by any release that provides the system."
(
when-let*
((
system-name
(
requirement
/
name
req
))
((
system-name
(
requirement
-
name
req
))
(
source
(
find-requirement-source
req
))
(
system
(
source-system
source
system-name
)))
(
let*
((
system-releases
(
system-system-releases
system
))
(
applicable-system-releases
(
remove-if-not
(
rcurry
#'
system-release-satisfies-version-spec-p
(
requirement
/
version-spec
req
))
(
requirement
-
version-spec
req
))
system-releases
)))
(
unless
system-releases
(
error
"No releases for ~S"
system-name
))
...
...
@@ -193,12 +193,12 @@ satisfying release."
(
defmethod
resolve-requirement
((
req
vcs-project-requirement
)
node
)
(
declare
(
ignore
node
))
(
let*
((
project-name
(
requirement
/
name
req
))
(
systems
(
requirement
/
systems
req
))
(
system-files
(
requirement
/
system-files
req
))
(
branch
(
requirement
/
branch
req
))
(
commit
(
requirement
/
commit
req
))
(
tag
(
requirement
/
tag
req
))
(
let*
((
project-name
(
requirement
-
name
req
))
(
systems
(
requirement
-
systems
req
))
(
system-files
(
requirement
-
system-files
req
))
(
branch
(
requirement
-
branch
req
))
(
commit
(
requirement
-
commit
req
))
(
tag
(
requirement
-
tag
req
))
(
source
(
find-requirement-source
req
nil
))
(
vcs-project
(
source-project
source
project-name
nil
))
(
vcs-release
(
project-vcs-release
vcs-project
...
...
src/clpm/resolve/search.lisp
View file @
1d3220e1
...
...
@@ -57,7 +57,7 @@
(
log:trace
"When groveling, found ~A is unsatisfied"
missing-req
)
(
if-let
((
candidate-file
(
and
(
typep
missing-req
'system-requirement
)
(
find
(
asdf:primary-system-name
(
requirement
/
name
missing-req
))
(
find
(
asdf:primary-system-name
(
requirement
-
name
missing-req
))
(
node-system-files-pending-groveling
new-search-node
)
:key
(
compose
#'
system-file-primary-system-name
#'
car
)
:test
#'
equal
))))
...
...
@@ -101,7 +101,7 @@
(
let
((
reqs
(
system-release-requirements
sr
)))
;; Mark the reason for the new reqs
(
mapc
(
lambda
(
r
)
(
setf
(
requirement
/
why
r
)
sr
))
(
setf
(
requirement
-
why
r
)
sr
))
reqs
)
;; Add the deps we just computed.
(
node-add-unresolved-reqs!
new-search-node
reqs
)))
...
...
@@ -130,12 +130,12 @@
(
node-add-resolution!
new-node
release
system-releases
nil
unresolved-req
)
;; And push its requirements, unless the requirement says to not
;; include deps.
(
unless
(
requirement
/
no-deps-p
unresolved-req
)
(
unless
(
requirement
-
no-deps-p
unresolved-req
)
(
dolist
(
sr
system-releases
)
(
let
((
new-reqs
(
system-release-requirements
sr
)))
;; Mark the reason for the new reqs
(
mapc
(
lambda
(
r
)
(
setf
(
requirement
/
why
r
)
sr
))
(
setf
(
requirement
-
why
r
)
sr
))
new-reqs
)
(
node-add-unresolved-reqs!
new-node
new-reqs
))))
(
values
new-node
(
not
(
null
resolutions
))))))))
...
...
@@ -221,7 +221,7 @@ observed in package-inferred-systems that are groveled after a refactoring
leaves some dead files around."
(
and
(
typep
req
'system-requirement
)
(
null
(
find-requirement-source
req
nil
))
(
node-find-system-if-active
node
(
asdf:primary-system-name
(
requirement
/
name
req
)))))
(
node-find-system-if-active
node
(
asdf:primary-system-name
(
requirement
-
name
req
)))))
(
defun
cleanup-search-node!
(
node
)
"Returns two values. The first is the search node with all satisfied
...
...
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