suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

raco setup: add package-dependency checking

Browse Source 
The new `--no-pkg-deps' or `-K' flag skips the check.

If a module in package X refers to a module in package Y, check that
package X declares a dependency on Y.  Note that package X must
specifically depend on Y --- not another package that at the moment
happens to declare a dependency on Y.

A new "base" package represents the content of the core (so that, if
the core shrinks, a new "base2" can represent the smaller core).
Most every package now needs a dependency on "base".

Sometimes, it makes sense for X to access Y when X declares a
dependency on Z, because Z promises to always depend on Y.  For
example, the "gui" package is defined to combne "gui-lib" and
"gui-doc", so it's appropriate to use the modules of "gui-lib" when
depending on "gui". A package's "info.rkt" can therefore define
`implies' as a subset of the dependencies listed in `deps', which
means that depending on the package implies a dependency on the listed
packages. (It's even possible for packages to mutually imply each
other, which is why the dependency checking code ends up with a
union-find.)

Dependency checking distinguishes between run-time dependencies and
build-time dependencies: anything listed in a ".dep" file is a build
dependency, at least. To imply a run-time dependency, a reference must
appear in a bytecode file's imports, and not in a subdirectory or
submodule that would be pruned for a binary package.

The `--fix-pkg-deps' flag attempts to automatically fix package
dependency declarations (i.e., modify a package's "info.rkt" file)
based on inferred dependencies.
This commit is contained in:
Matthew Flatt 2013-06-28 21:04:59 -06:00
parent 05dfce142b
commit 04d5d9bd55
15 changed files with 667 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
pkgs/base/info.rkt Normal file
View File

@ -0,0 +1,11 @@
#lang setup/infotab
;; The "base" package exists only as a way to declare dependencies
;; on the current Racket core. If the core gets smaller in the
;; future, then "base" can have new dependencies to cover things
;; moved out of the core, while a new "base2" package can represent
;; the new, smaller core.
(define collection 'multi)
(define implies '(core))

42
pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl
View File

@ -78,10 +78,11 @@ catalogs}.}
A structure type that is used to report installed-package information.}
@defproc[(pkg-directory [name string?]) path-string?]{
@defproc[(pkg-directory [name string?]) (or/c path-string? #f)]{
Returns the directory that holds the installation of the installed
(in any scope) package @racket[name].}
(in any scope) package @racket[name], or @racket[#f] if no such package
is installed.}
@defproc[(path->pkg [path path-string?]) (or/c string? #f)]{
@ -129,16 +130,25 @@ dependency.}
@defproc[(pkg-stage [desc pkg-desc?]
[#:checksum checksum (or/c #f string?) #f])
(values string? path? (or/c #f string?) boolean?)]{
[#:checksum checksum (or/c #f string?) #f]
[#:in-place? in-place? boolean? #f]
[#:namespace namespace namespace? (make-base-namespace)])
(values string? path? (or/c #f string?) boolean? (listof module-path?))]{
Locates the implementation of the package specified by @racket[desc] and
downloads and unpacks it to a temporary directory (as needed).
Locates the implementation of the package specified by @racket[desc]
and downloads and unpacks it to a temporary directory (as needed).
If @racket[desc] refers to an existing directory and
@racket[in-place?] is true, then the directory is used in place.
The @racket[namespace] argument is passed along to
@racket[get-info/full] when the package's @filepath{info.rkt} is
loaded.
The result is the package name, the directory containing the unpacked package content,
the checksum (if any) for the unpacked package, and whether the
the checksum (if any) for the unpacked package, whether the
directory should be removed after the package content is no longer
needed.}
needed, and a list of module paths provided by the package.}
@defproc[(pkg-config [set? boolean?] [keys/vals list?])
@ -345,3 +355,19 @@ The results are as follows:
@racket[get-info].}
]}
@defproc[(extract-pkg-dependencies [info (symbol? (-> any/c) . -> . any/c)]
[#:build-deps? build-deps? boolean? #f]
[#:filter? filter? boolean? #f])
(listof (or/c string? (cons/c string? list?)))]{
Returns packages dependencies reported by the @racket[info] procedure
(normally produced by @racket[get-info]).
If @racket[build-deps?] is true, then the result includes both
run-time dependencies and build-time dependencies.
If @racket[filter?] is true, then platform-specific dependencies are
removed from the result list when they do not apply to the current
platform, and other information is stripped so that the result list is
always a list of strings.}

12
pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl
View File

@ -816,6 +816,18 @@ The following @filepath{info.rkt} fields are used by the package manager:
@racketidfont{build-deps} when converting a package for
@DFlag{binary} mode.}
@item{@racketidfont{implies} --- a list of strings and
@racket['core]. Each string refers to a package listed in the
@racketidfont{deps} and indicates that a dependency on the
current package counts as a dependency on named package; for
example, the @pkgname{gui} package is defined to ensure access
to all of the libraries provided by @pkgname{gui-lib}, so the
@filepath{info.rkt} file of @pkgname{gui} lists
@racket["gui-lib"] in @racketidfont{implies}. The special value
@racket['core] is intended for use by an appropriate
@pkgname{base} package to declare it as the representative of
core Racket libraries.}
@item{@racketidfont{setup-collects} --- a list of path strings and/or
lists of path strings, which are used as collection names to
set up via @exec{raco setup} after the package is installed, or

18
pkgs/racket-pkgs/racket-doc/scribblings/raco/setup.scrbl
View File

@ -166,6 +166,16 @@ flags:
@item{@DFlag{avoid-main} --- refrain from any setup actions that
affect the installation, as opposed to user-specific actions.}
@item{@DFlag{no-pkg-deps} or @Flag{K} --- refrain from checking whether dependencies among
libraries are properly reflected by package-level dependency
declarations. The check uses compiled bytecode and associated
@filepath{.dep} files, and it checks only files are setup against
only packages that include files that are setup.}
@item{@DFlag{fix-pkg-deps} --- attempt to correct dependency
mismatches by adjusting package @filepath{info.rkt} files (which makes
sense only for packages that are installed as links).}
@item{@DFlag{mode} @nonterm{mode} --- use a @filepath{.zo} compiler
other than the default compiler, and put the resulting
@filepath{.zo} files in a subdirectory (of the usual place) named
@ -176,16 +186,16 @@ flags:
@racket[compile]; see the @filepath{errortrace} collection for an
example.}
@item{@DFlag{verbose} or @Flag{v} --- More verboase output about
@item{@DFlag{verbose} or @Flag{v} --- more verbose output about
@exec{raco setup} actions.}
@item{@DFlag{make-verbose} or @Flag{m} --- More verboase output about
@item{@DFlag{make-verbose} or @Flag{m} --- more verbose output about
dependency checks.}
@item{@DFlag{compiler-verbose} or @Flag{r} --- Even more verbose
@item{@DFlag{compiler-verbose} or @Flag{r} --- even more verbose
output about dependency checks and compilation.}
@item{@DFlag{pause} or @Flag{p} --- Pause for user input if any
@item{@DFlag{pause} or @Flag{p} --- pause for user input if any
errors are reported (so that a user has time to inspect output that
might otherwise disappear when the @exec{raco setup} process ends).}

1
pkgs/racket-pkgs/racket-test/tests/pkg/tests-deps.rkt
View File

@ -134,6 +134,7 @@
(with-fake-root
(shelly-case
"remote - fail"
$ "raco pkg config --set catalogs http://localhost:9990"
$ "racket -e '(require pkg-test2)'" =exit> 1
$ "raco pkg install --deps fail pkg-test2" =exit> 1
$ "racket -e '(require pkg-test2)'" =exit> 1)))))

27
pkgs/racket-pkgs/racket-test/tests/pkg/tests-install.rkt
View File

@ -36,18 +36,21 @@
(shelly-install "remote/URL/http package (directory)"
"http://localhost:9999/pkg-test1/")
(shelly-case
"fails due to unrecognized scheme"
$ "raco pkg install magic://download" =exit> 1)
(shelly-case
"local directory name fails because not inferred as such (inferred as package name)"
$ "raco pkg install test-pkgs" =exit> 1)
(shelly-case
"local file name with bad suffix and not a package name or directory"
$ "raco pkg install tests-install.rkt" =exit> 1)
(shelly-case
"not a valid (inferred) package name"
$ "raco pkg install 1+2" =exit> 1)
(with-fake-root
(shelly-begin
$ "raco pkg config --set catalogs http://localhost:9990 http://localhost:9991"
(shelly-case
"fails due to unrecognized scheme"
$ "raco pkg install magic://download" =exit> 1)
(shelly-case
"local directory name fails because not inferred as such (inferred as package name)"
$ "raco pkg install test-pkgs" =exit> 1)
(shelly-case
"local file name with bad suffix and not a package name or directory"
$ "raco pkg install tests-install.rkt" =exit> 1)
(shelly-case
"not a valid (inferred) package name"
$ "raco pkg install 1+2" =exit> 1)))
(shelly-case
"local file fails because called a directory"

3
pkgs/redex/tut-subst.rkt
View File

@ -17,8 +17,7 @@ for untyped.
|#
(require racket/set racket/match
redex/reduction-semantics
rackunit)
redex/reduction-semantics)
(provide subst/proc fvs)
(define (subst/proc x? vars replacements body)

206
racket/lib/collects/pkg/lib.rkt
View File

@ -581,7 +581,8 @@
[_
(build-path (pkg-installed-dir) pkg-name)]))))
(define (path->pkg+subpath given-p)
(define (path->pkg+subpath given-p
#:cache [cache #f])
(define (explode p)
(explode-path
(normal-case-path
@ -596,31 +597,44 @@
(if (null? l) 'same (apply build-path l)))
(for/fold ([pkg #f] [subpath #f]) ([scope (in-list (get-scope-list))]
#:when (not pkg))
(parameterize ([current-pkg-scope scope])
(with-pkg-lock/read-only
(define d (explode (pkg-installed-dir)))
(cond
[(sub-path? < p d)
;; Under the installation mode's package directory.
;; We assume that no one else writes there, so the
;; next path element is the package name.
(define len (length d))
(values (path-element->string (list-ref p len))
(build-path* (list-tail p (add1 len))))]
[else
;; Maybe it's a linked package
(for/fold ([pkg #f] [subpath #f]) ([(k v) (in-hash (read-pkg-db))]
#:when (not pkg))
(match (pkg-info-orig-pkg v)
[`(link ,orig-pkg-dir)
(define e (explode orig-pkg-dir))
(if (sub-path? <= p e)
(values k (build-path* (list-tail p (length e))))
(values #f #f))]
[else (values #f #f)]))])))))
(define d (or (and cache
(hash-ref cache `(dir ,scope) #f))
(parameterize ([current-pkg-scope scope])
(with-pkg-lock/read-only
(define d (explode (pkg-installed-dir)))
(when cache (hash-set! cache `(dir ,scope) d))
d))))
(define (read-pkg-db/cached)
(or (and cache
(hash-ref cache `(db ,scope) #f))
(parameterize ([current-pkg-scope scope])
(with-pkg-lock/read-only
(define db (read-pkg-db))
(when cache (hash-set! cache `(db ,scope) db))
db))))
(cond
[(sub-path? < p d)
;; Under the installation mode's package directory.
;; We assume that no one else writes there, so the
;; next path element is the package name.
(define len (length d))
(values (path-element->string (list-ref p len))
(build-path* (list-tail p (add1 len))))]
[else
;; Maybe it's a linked package
(for/fold ([pkg #f] [subpath #f]) ([(k v) (in-hash (read-pkg-db/cached))]
#:when (not pkg))
(match (pkg-info-orig-pkg v)
[`(link ,orig-pkg-dir)
(define e (explode orig-pkg-dir))
(if (sub-path? <= p e)
(values k (build-path* (list-tail p (length e))))
(values #f #f))]
[else (values #f #f)]))])))
(define (path->pkg given-p)
(define-values (pkg rest) (path->pkg+subpath given-p))
(define (path->pkg given-p #:cache [cache #f])
(define-values (pkg rest)
(path->pkg+subpath given-p #:cache cache))
pkg)
(define ((remove-package quiet?) pkg-name)
@ -729,14 +743,16 @@
c)))
;; Downloads a package (if needed) and unpacks it (if needed) into a
;; temporary directory.
;; temporary directory.
(define (stage-package/info pkg
given-type
given-pkg-name
#:given-checksum [given-checksum #f]
check-sums?
download-printf
metadata-ns)
metadata-ns
#:in-place? [in-place? #f]
#:in-place-clean? [in-place-clean? #f])
(define-values (inferred-pkg-name type)
(if (path? pkg)
(package-source->name+type (path->string pkg)
@ -804,19 +820,25 @@
(λ ()
(download-printf "Downloading ~a\n" (url->string new-url))
(download-file! new-url tmp.tgz)
(define staged? #f)
(dynamic-wind
void
(λ ()
(untar tmp.tgz tmp-dir #:strip-components 1)
(stage-package/info (path->string package-path)
'dir
pkg-name
#:given-checksum checksum
check-sums?
download-printf
metadata-ns))
(begin0
(stage-package/info (path->string package-path)
'dir
pkg-name
#:given-checksum checksum
check-sums?
download-printf
metadata-ns
#:in-place? #t
#:in-place-clean? #t)
(set! staged? #t)))
(λ ()
(delete-directory/files tmp-dir))))
(unless staged?
(delete-directory/files tmp-dir)))))
(λ ()
(delete-directory/files tmp.tgz)))]
[_
@ -937,6 +959,7 @@
(define pkg-dir
(make-temporary-file (string-append "~a-" pkg-name)
'directory))
(define staged? #t)
(dynamic-wind
void
(λ ()
@ -961,19 +984,24 @@
[x
(pkg-error "invalid package format\n given: ~a" x)])
(update-install-info-checksum
(update-install-info-orig-pkg
(stage-package/info pkg-dir
'dir
pkg-name
#:given-checksum checksum
check-sums?
download-printf
metadata-ns)
`(file ,(simple-form-path* pkg)))
checksum))
(begin0
(update-install-info-checksum
(update-install-info-orig-pkg
(stage-package/info pkg-dir
'dir
pkg-name
#:given-checksum checksum
check-sums?
download-printf
metadata-ns
#:in-place? #t
#:in-place-clean? #t)
`(file ,(simple-form-path* pkg)))
checksum)
(set! staged? #t)))
(λ ()
(delete-directory/files pkg-dir)))]
(unless staged?
(delete-directory/files pkg-dir))))]
[(or (eq? type 'dir)
(eq? type 'link))
(unless (directory-exists? pkg)
@ -988,14 +1016,18 @@
(directory->module-paths pkg pkg-name metadata-ns))]
[else
(define pkg-dir
(make-temporary-file "pkg~a" 'directory))
(delete-directory pkg-dir)
(make-parent-directory* pkg-dir)
(copy-directory/files pkg pkg-dir #:keep-modify-seconds? #t)
(if in-place?
pkg
(let ([pkg-dir (make-temporary-file "pkg~a" 'directory)])
(delete-directory pkg-dir)
(make-parent-directory* pkg-dir)
(copy-directory/files pkg pkg-dir #:keep-modify-seconds? #t)
pkg-dir)))
(install-info pkg-name
`(dir ,(simple-form-path* pkg))
pkg-dir
#t #f
(or (not in-place?) in-place-clean?)
#f
(directory->module-paths pkg-dir pkg-name metadata-ns))]))]
[(eq? type 'name)
(define catalog-info (package-catalog-lookup pkg #f))
@ -1021,18 +1053,22 @@
(pkg-error "cannot infer package source type\n source: ~a" pkg)]))
(define (pkg-stage desc
#:checksum [checksum #f])
#:namespace [metadata-ns (make-metadata-namespace)]
#:checksum [checksum #f]
#:in-place? [in-place? #f])
(define i (stage-package/info (pkg-desc-source desc)
(pkg-desc-type desc)
(pkg-desc-name desc)
#:given-checksum checksum
#t
void
(make-metadata-namespace)))
metadata-ns
#:in-place? in-place?))
(values (install-info-name i)
(install-info-directory i)
(install-info-checksum i)
(install-info-clean? i)))
(install-info-clean? i)
(install-info-module-paths i)))
(define (install-packages
#:old-infos [old-infos empty]
@ -1048,6 +1084,7 @@
(define download-printf (if quiet? void printf))
(define check-sums? (not ignore-checksums?))
(define all-db (merge-pkg-dbs))
(define path-pkg-cache (make-hash))
(define (install-package/outer infos desc info)
(match-define (pkg-desc pkg type orig-name auto?) desc)
(match-define
@ -1085,9 +1122,9 @@
(path-replace-suffix name #".ss")
#".zo"))))))
(or (not updating?)
(not (equal? pkg-name (path->pkg f)))))
(not (equal? pkg-name (path->pkg f #:cache path-pkg-cache)))))
;; This module is already installed
(cons (path->pkg f) mp)]
(cons (path->pkg f #:cache path-pkg-cache) mp)]
[else
;; Compare with simultaneous installs
(for/or ([other-pkg-info (in-list infos)]
@ -1974,27 +2011,35 @@
ht
(hash-set ht k v)))))
(define (extract-dependencies get-info)
(define (extract-pkg-dependencies get-info
#:build-deps? [build-deps? #t]
#:filter? [filter? #f])
(define v (if get-info
(get-info 'deps (lambda () empty))
empty))
((check-dependencies 'deps) v)
(define v2 (if get-info
(get-info 'build-deps (lambda () empty))
empty))
(define v2 (if (and get-info build-deps?)
(get-info 'build-deps (lambda () empty))
empty))
((check-dependencies 'build-deps) v2)
(append v v2))
(define all-v (append v v2))
(if filter?
(for/list ([dep (in-list all-v)]
#:when (dependency-this-platform? dep))
(if (pair? dep)
(car dep)
dep))
all-v))
(define (get-pkg-content desc
#:extract-info [extract-info extract-dependencies])
(define-values (pkg-name dir cksum clean?) (pkg-stage desc))
(define metadata-ns (make-metadata-namespace))
#:namespace [metadata-ns (make-metadata-namespace)]
#:extract-info [extract-info extract-pkg-dependencies])
(define-values (pkg-name dir cksum clean? module-paths)
(pkg-stage desc #:in-place? #t #:namespace metadata-ns))
(define get-info (get-info/full dir #:namespace metadata-ns))
(define module-paths
(set->list (directory->module-paths dir pkg-name metadata-ns)))
(begin0
(values cksum
module-paths
(set->list module-paths)
(extract-info get-info))
(when clean?
(delete-directory/files dir))))
@ -2164,11 +2209,15 @@
[current-pkg-catalogs
(parameter/c (or/c #f (listof url?)))]
[pkg-directory
(-> string? path-string?)]
(-> string? (or/c path-string? #f))]
[path->pkg
(-> path-string? (or/c #f string?))]
(->* (path-string?)
(#:cache (or/c #f (and/c hash? (not/c immutable?))))
(or/c #f string?))]
[path->pkg+subpath
(-> path-string? (values (or/c #f string?) (or/c #f 'same path?)))]
(->* (path-string?)
(#:cache (or/c #f (and/c hash? (not/c immutable?))))
(values (or/c #f string?) (or/c #f 'same path?)))]
[pkg-desc
(-> string?
(or/c #f 'file 'dir 'link 'file-url 'dir-url 'github 'name)
@ -2235,11 +2284,14 @@
(#:scope (or/c #f package-scope/c))
(hash/c string? pkg-info?))]
[pkg-stage (->* (pkg-desc?)
(#:checksum (or/c #f string?))
(#:namespace namespace?
#:checksum (or/c #f string?)
#:in-place? boolean?)
(values string?
path?
(or/c #f string?)
boolean?))]
boolean?
(listof module-path?)))]
[pkg-config-catalogs
(-> (listof string?))]
[pkg-catalog-update-local
@ -2263,10 +2315,16 @@
(->* (pkg-desc?)
(#:extract-info (-> (or/c #f
((symbol?) ((-> any)) . ->* . any))
any/c))
any/c)
#:namespace namespace?)
(values (or/c #f string?)
(listof module-path?)
any/c))]
[extract-pkg-dependencies
(->* ((symbol? (-> any/c) . -> . any/c))
(#:build-deps? boolean?
#:filter? boolean?)
(listof (or/c string? (cons/c string? list?))))]
[pkg-single-collection
(->* (path-string?)
(#:name string?

1
racket/lib/collects/racket/HISTORY.txt
View File

@ -10,6 +10,7 @@ Added links-file and links-search-dirs to config, enabling
as pkgs-dir and pkgs-search-dirs
Removed -C/--links command-line flag
setup/infotab: removed string-constants require as an allowed form
raco setup: added --no-pkg-deps and --fix-pkg-deps
Version 5.3.900.1
Reorganized collections into packages

2
racket/lib/collects/setup/option-sig.rkt
View File

@ -22,6 +22,8 @@
avoid-main-installation
make-tidy
make-doc-index
check-dependencies
fix-dependencies
call-install
call-post-install
pause-on-errors

2
racket/lib/collects/setup/option-unit.rkt
View File

@ -47,6 +47,8 @@
(define-flag-param avoid-main-installation #f)
(define-flag-param make-tidy #f)
(define-flag-param make-doc-index #f)
(define-flag-param check-dependencies #t)
(define-flag-param fix-dependencies #f)
(define-flag-param call-install #t)
(define-flag-param call-post-install #t)
(define-flag-param pause-on-errors #f)

410
racket/lib/collects/setup/private/pkg-deps.rkt Normal file
View File

@ -0,0 +1,410 @@
#lang racket/base
(require syntax/modread
syntax/modcollapse
pkg/lib
racket/set
racket/string
racket/list
setup/getinfo
racket/file)
(provide check-package-dependencies)
(define core-pkg "base")
;; Submodules with these names are dropped in binary
;; packages, so they only controbute to `build-deps':
(define build-only-submod-names '(test doc srcdoc))
(define (check-package-dependencies
paths
coll-paths
coll-modes
setup-printf setup-fprintf
fix? verbose?)
;; Tables
(define missing (make-hash))
(define pkg-internal-deps (make-hash)) ; dependencies available for a package's own use
(define pkg-immediate-deps (make-hash)) ; save immediate dependencies
(define pkg-external-deps (make-hash)) ; dependencies made available though `implies'
(define pkg-reps (make-hash)) ; for union-find on external deps
(define mod-pkg (make-hash))
(define path-cache (make-hash))
(define metadata-ns (make-base-namespace))
;; ----------------------------------------
;; Find the canonical representative for a set of external dependencies:
(define (find-rep! pkg)
(define rep-pkg (hash-ref pkg-reps pkg))
(if (equal? rep-pkg pkg)
pkg
(let ([rep-pkg (find-rep! rep-pkg)])
(hash-set! pkg-reps pkg rep-pkg)
rep-pkg)))
;; ----------------------------------------
;; Equate `a-pkg' and `b-pkg', returning a representative:
(define (union-find! a-pkg b-pkg)
(define rep-a-pkg (find-rep! a-pkg))
(define rep-b-pkg (find-rep! b-pkg))
(unless (equal? rep-a-pkg rep-b-pkg)
(define a-deps (hash-ref pkg-reps rep-a-pkg))
(define b-deps (hash-ref pkg-reps rep-b-pkg))
(hash-set! pkg-reps rep-b-pkg (set-union a-deps b-deps))
(hash-remove! pkg-external-deps rep-a-pkg)
(hash-set! pkg-reps rep-a-pkg rep-b-pkg))
rep-b-pkg)
;; ----------------------------------------
;; Get a package's info, returning its deps and implies:
(define (get-immediate-pkg-info! pkg)
(define dir (pkg-directory pkg))
(unless dir
(error 'check-dependencies "package not installed: ~s" pkg))
;; Get package information:
(define-values (checksum mods deps+build-deps)
(get-pkg-content (pkg-desc (if (path? dir) (path->string dir) dir) 'dir pkg #f)
#:namespace metadata-ns
#:extract-info (lambda (i)
(if i
(cons
(extract-pkg-dependencies i
#:build-deps? #f
#:filter? #t)
(extract-pkg-dependencies i
#:filter? #t))
(cons '() '())))))
(define deps (cdr deps+build-deps))
(define runtime-deps (list->set (car deps+build-deps)))
(define implies
(list->set (let ([i (get-info/full dir #:namespace metadata-ns)])
(if i
(i 'implies (lambda () null))
null))))
;; check that `implies' is a subset of `deps'
(for ([i (in-set implies)])
(unless (eq? i 'core)
(unless (set-member? runtime-deps i)
(setup-fprintf (current-error-port) #f
(string-append
"implied package is not declared as a dependency:\n"
" in package: ~s\n"
" implied package: ~s\n")
pkg
i))))
(for ([mod (in-list mods)])
(hash-set! mod-pkg mod pkg))
;; Save immediate dependencies, initialize external dependencies:
(hash-set! pkg-reps pkg pkg)
(hash-set! pkg-immediate-deps pkg (list
(set-add runtime-deps
pkg)
(set-add (list->set deps)
pkg)))
(hash-set! pkg-external-deps pkg (set-add (set-intersect
implies
(set-add runtime-deps
'core))
pkg))
(values deps implies))
;; ----------------------------------------
;; Flatten package dependencies, record mod->pkg mappings,
;; return representative package name (of a recursive set)
(define (register-pkg! pkg ancestors)
(cond
[(hash-ref pkg-reps pkg #f)
=> (lambda (rep-pkg) rep-pkg)]
[else
(when verbose?
(setup-printf #f " checking dependencies of ~s" pkg))
(define-values (deps implies) (get-immediate-pkg-info! pkg))
;; Recur on all dependencies
(define new-ancestors (hash-set ancestors pkg #t))
(define rep-pkg
(for/fold ([rep-pkg pkg]) ([dep (in-list deps)])
(define dep-rep-pkg (register-pkg! dep ancestors))
(cond
[(not (set-member? implies dep))
;; not implied, so doesn't add external dependencies
rep-pkg]
[(equal? dep-rep-pkg rep-pkg)
;; an "implies" cycle that points back here - done!
rep-pkg]
[(hash-ref ancestors dep-rep-pkg #f)
;; an "implies" cycle back to an ancestor; union to ancestor
(union-find! rep-pkg dep-rep-pkg)]
[else
;; assert: external deps of `dep-rep-pkg' will not change anymore
(define new-rep-pkg (find-rep! rep-pkg))
(hash-set! pkg-external-deps
rep-pkg
(set-union (hash-ref pkg-external-deps dep-rep-pkg)
(hash-ref pkg-external-deps new-rep-pkg)))
new-rep-pkg])))
rep-pkg]))
;; ----------------------------------------
;; Fill in package internal dependencies, given that immediate-dependency
;; external-dependency information is available for all relevant packages:
(define (init-pkg-internals! pkg)
(unless (hash-ref pkg-internal-deps pkg #f)
;; register modules and compute externally visible dependencies
(register-pkg! pkg (hash))
;; combine flattened external dependencies to determine internal dependencies
(define (flatten imm-deps)
(for/fold ([deps (set)]) ([dep (in-set imm-deps)])
(set-union deps
(hash-ref pkg-external-deps (find-rep! dep)))))
(let ([imm-depss (hash-ref pkg-immediate-deps pkg)])
(hash-set! pkg-internal-deps
pkg
(map flatten imm-depss)))
(when verbose?
(define (make-list s)
(apply
string-append
(for/list ([k (in-set s)])
(format "\n ~s" k))))
(setup-printf #f
(string-append
" declared accesses, counting `implies'\n"
" for package: ~s\n"
" packages:~a"
" packages for build:~a")
pkg
(make-list (car (hash-ref pkg-internal-deps pkg)))
(make-list (cadr (hash-ref pkg-internal-deps pkg)))))))
;; ----------------------------------------
;; Check use of `mod' (in `mode') from `pkg' by file `f':
(define (check mod mode pkg f)
(define src-pkg (or (hash-ref mod-pkg mod #f)
'core))
(when src-pkg
(define flat-depss (hash-ref pkg-internal-deps pkg))
(unless (set-member? (if (eq? mode 'run)
(car flat-depss)
(cadr flat-depss))
src-pkg)
(hash-update! missing pkg
(lambda (h)
(hash-update h src-pkg
(lambda (old-mode)
(if (eq? mode old-mode)
mode
'run))
mode))
(hash))
(when verbose?
(setup-fprintf (current-error-port) #f
(string-append
" found undeclared dependency:\n"
" mode: ~s\n"
" for package: ~s\n"
" on package: ~s\n"
" dependent source: ~a\n"
" used module: ~s")
mode
pkg
src-pkg
f
mod)))))
;; For each collection, set up package info:
(for ([path (in-list paths)])
(define pkg (path->pkg path #:cache path-cache))
(when pkg
(init-pkg-internals! pkg)))
;; For each collection, check its dependencies:
(for ([path (in-list paths)]
[coll-path (in-list coll-paths)]
[coll-mode (in-list coll-modes)])
(when verbose?
(setup-printf #f " checking ~a" path))
(define dir (build-path path "compiled"))
(when (directory-exists? dir)
(define pkg (path->pkg dir #:cache path-cache))
(when pkg
(for ([f (directory-list dir)])
;; A ".dep" file triggers a check:
(when (regexp-match? #rx#"[.]dep$" (path-element->bytes f))
(define deps (cddr (call-with-input-file* (build-path dir f) read)))
;; Decide whether the file is inherently 'build or 'run mode:
(define mode
(if (or (eq? coll-mode 'build)
(regexp-match? #rx#"_scrbl[.]dep$" (path-element->bytes f)))
'build
'run))
;; Treat everything in ".dep" as 'build mode...
(for ([dep (in-list deps)])
(when (and (pair? dep)
(eq? 'collects (car dep)))
(define path-strs (map bytes->string/utf-8 (cdr dep)))
(define mod `(lib ,(string-join path-strs "/")))
(check mod 'build pkg f)))
;; Look at the actual module for 'run mode (dropping
;; submodules like `test'):
(when (eq? mode 'run)
;; This is the slowest part, because we have to read the module ".zo"
(define zo-f (path-replace-suffix f #".zo"))
(when (file-exists? (build-path dir zo-f))
(define base (let ([m (regexp-match #rx#"^(.*)_[a-z]+[.]zo$"
(path-element->bytes zo-f))])
(and m (bytes->string/utf-8 (cadr m)))))
(define in-mod `(lib ,(string-join
(append (map path-element->string coll-path) (list base))
"/")))
(define mod-code (call-with-input-file*
(build-path dir zo-f)
(lambda (i)
(parameterize ([read-accept-compiled #t])
(read i)))))
;; Recur to cover submodules:
(let loop ([mod-code mod-code])
(define name (module-compiled-name mod-code))
(unless (and (list? name)
(memq (last name) build-only-submod-names))
;; Check the module's imports:
(for* ([imports (in-list (module-compiled-imports mod-code))]
[import (cdr imports)])
(define mod (let ([m (collapse-module-path-index import in-mod)])
(if (and (pair? m)
(eq? (car m) 'submod))
(cadr m)
m)))
(when (and (pair? mod) (eq? 'lib (car mod)))
(check mod 'run pkg zo-f)))
;; Recur for submodules:
(for-each loop
(append
(module-compiled-submodules mod-code #t)
(module-compiled-submodules mod-code #f))))))))))))
;; Report result summary and (optionally) repair:
(for ([pkg (in-list (sort (hash-keys missing) string<?))])
(define pkgs (hash-ref missing pkg))
(define modes '(run build))
(define pkgss (for/list ([mode modes])
(sort
(for/list ([(pkg pkg-mode) (in-hash pkgs)]
#:when (eq? mode pkg-mode))
(if (eq? pkg 'core)
core-pkg
pkg))
string<?)))
(apply setup-fprintf (current-error-port) #f
(apply
string-append
"undeclared dependency detected\n"
" for package: ~s"
(for/list ([pkgs (in-list pkgss)]
[mode (in-list modes)]
#:when (pair? pkgs))
(format "\n on package~a~a:~~a"
(if (null? (cdr pkgs)) "" "s")
(case mode
[(run) ""]
[(build) " for build"]))))
pkg
(for/list ([pkgs (in-list pkgss)]
[mode (in-list modes)]
#:when (pair? pkgs))
(apply
string-append
(for/list ([k (in-list pkgs)])
(format "\n ~s" k)))))
(when fix?
(define info-path (build-path (pkg-directory pkg) "info.rkt"))
(setup-printf #f "repairing ~s..." info-path)
(fix-info-deps-definition info-path 'deps (car pkgss))
(fix-info-deps-definition info-path 'build-deps (cadr pkgss)))))
(define (fix-info-deps-definition info-path deps-id pkgs)
(unless (null? pkgs)
(unless (file-exists? info-path)
(call-with-output-file*
info-path
(lambda (o)
(displayln "#lang setup/infotab" o))))
(define stx (call-with-input-file*
info-path
(lambda (i)
(port-count-lines! i)
(with-module-reading-parameterization
(lambda ()
(read-syntax info-path i))))))
(define deps-stx
(syntax-case stx ()
[(mod name lang (#%mb def ...))
(for/or ([def (in-list (syntax->list #'(def ...)))])
(syntax-case def ()
[(dfn id rhs)
(eq? 'define (syntax-e #'dfn))
(and (eq? deps-id (syntax-e #'id))
def)]
[_ #f]))]
[_
(error 'fix-deps "could not parse ~s" info-path)]))
(cond
[deps-stx
(define (fixup prefix start indent)
(unless (and start indent)
(error 'fix-deps
"could get relevant source location for `~a' definition in ~s"
deps-id
info-path))
(define str (file->string info-path))
(define new-str
(string-append (substring str 0 start)
(apply
string-append
(for/list ([s (in-list pkgs)])
(format "~a~s\n~a"
prefix
s
(make-string indent #\space))))
(substring str start)))
(call-with-output-file*
info-path
#:exists 'truncate
(lambda (o) (display new-str o))))
(define (x+ a b) (and a b (+ a b)))
(syntax-case deps-stx ()
[(def id (quot parens))
(and (eq? 'quote (syntax-e #'quot))
(or (null? (syntax-e #'parens))
(pair? (syntax-e #'parens))))
(fixup ""
(syntax-position #'parens)
(add1 (syntax-column #'parens)))]
[(def id (lst . elms))
(eq? 'list (syntax-e #'lst))
(syntax-case deps-stx ()
[(_ _ parens)
(fixup " "
(x+ (x+ (syntax-position #'lst)
-1)
(syntax-span #'lst))
(x+ (syntax-column #'lst)
(syntax-span #'lst)))])]
[_
(error 'fix-deps
"could parse `~a' definition in ~s"
deps-id
info-path)])]
[else
(define prefix (format "(define ~a '(" deps-id))
(call-with-output-file*
info-path
#:exists 'append
(lambda (o)
(display prefix o)
(for ([pkg (in-list pkgs)]
[i (in-naturals)])
(unless (zero? i)
(newline o)
(display (make-string (string-length prefix) #\space) o))
(write pkg o))
(displayln "))" o)))])))

5
racket/lib/collects/setup/setup-cmdline.rkt
View File

@ -78,6 +78,11 @@
(add-flags '((make-planet #f)))]
[("--avoid-main") "Do not make main-installation files"
(add-flags '((avoid-main-installation #t)))]
[("--no-pkg-deps") "Do not check package dependencies"
(add-flags '((check-dependencies #f)))]
[("-K" "--fix-pkg-deps") "Auto-repair package-dependency declarations"
(add-flags '((check-dependencies #t)
(fix-dependencies #t)))]
[("--mode") mode "Select a compilation mode"
(add-flags `((compile-mode ,mode)))]
[("-v" "--verbose") "See names of compiled files and info printfs"

27
racket/lib/collects/setup/setup-unit.rkt
View File

@ -30,7 +30,8 @@
"private/omitted-paths.rkt"
"parallel-build.rkt"
"private/cc-struct.rkt"
"link.rkt")
"link.rkt"
"private/pkg-deps.rkt")
(define-namespace-anchor anchor)
@ -1563,6 +1564,27 @@
(bytes->path-element (bytes-append #"man" (filename-extension n)))
n))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Package-dependency checking ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (do-check-package-dependencies)
(setup-printf #f (format "--- checking package dependencies ---"))
(check-package-dependencies (map cc-path ccs-to-compile)
(map cc-collection ccs-to-compile)
;; If "test" or "scribblings" is this collection's name,
;; then it's build-mode code, otherwise it's test mode:
(let ([tests-path (string->path "tests")]
[scribblings-path (string->path "scribblings")])
(for/list ([cc (in-list ccs-to-compile)])
(if (or (member tests-path (cc-collection cc))
(member scribblings-path (cc-collection cc)))
'build
'run)))
setup-printf setup-fprintf
(fix-dependencies)
(verbose)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; setup-unit Body ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1601,4 +1623,7 @@
(do-install-part 'general)
(do-install-part 'post)
(when (check-dependencies)
(do-check-package-dependencies))
(done))

17
racket/src/link-all.rkt
View File

@ -102,22 +102,7 @@
(error 'link-all "requested package not available: ~s" pkg-name))
(define i (get-info/full dir))
(define deps
(for/list ([dep (in-list (append (i 'deps (lambda () null))
(i 'build-deps (lambda () null))))]
#:when
(let ([platform (and (list? dep)
(member '#:platform dep))])
(or (not platform)
(let ([p (cadr platform)])
(if (symbol? p)
(eq? p (system-type))
(let ([s (path->string (system-library-subpath #f))])
(if (regexp? p)
(regexp-match? p s)
(equal? p s))))))))
(if (pair? dep)
(car dep)
dep)))
(extract-pkg-dependencies i #:filter? #t))
(set-union
new-pkgs
(for/set ([dep (in-list deps)]