From 04d5d9bd55d8258221e6e4cfba0c7991498202ed Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 28 Jun 2013 21:04:59 -0600 Subject: [PATCH] raco setup: add package-dependency checking 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. --- pkgs/base/info.rkt | 11 + .../racket-doc/pkg/scribblings/lib.scrbl | 42 +- .../racket-doc/pkg/scribblings/pkg.scrbl | 12 + .../racket-doc/scribblings/raco/setup.scrbl | 18 +- .../racket-test/tests/pkg/tests-deps.rkt | 1 + .../racket-test/tests/pkg/tests-install.rkt | 27 +- pkgs/redex/tut-subst.rkt | 3 +- racket/lib/collects/pkg/lib.rkt | 206 +++++---- racket/lib/collects/racket/HISTORY.txt | 1 + racket/lib/collects/setup/option-sig.rkt | 2 + racket/lib/collects/setup/option-unit.rkt | 2 + .../lib/collects/setup/private/pkg-deps.rkt | 410 ++++++++++++++++++ racket/lib/collects/setup/setup-cmdline.rkt | 5 + racket/lib/collects/setup/setup-unit.rkt | 27 +- racket/src/link-all.rkt | 17 +- 15 files changed, 667 insertions(+), 117 deletions(-) create mode 100644 pkgs/base/info.rkt create mode 100644 racket/lib/collects/setup/private/pkg-deps.rkt diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt new file mode 100644 index 0000000000..6cb227482e --- /dev/null +++ b/pkgs/base/info.rkt @@ -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)) diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl index 5733f3f717..c5844d5448 100644 --- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl +++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl @@ -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.} diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl index d5d2375046..31c3e2d36f 100644 --- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl +++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl @@ -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 diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/raco/setup.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/raco/setup.scrbl index 014f00b222..01b15af138 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/raco/setup.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/raco/setup.scrbl @@ -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).} diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-deps.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-deps.rkt index 656a569f82..dbbc9fd319 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-deps.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-deps.rkt @@ -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))))) diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-install.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-install.rkt index a9da17dbc2..e767e30556 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-install.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-install.rkt @@ -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" diff --git a/pkgs/redex/tut-subst.rkt b/pkgs/redex/tut-subst.rkt index 5f7e027e06..255c623c5b 100644 --- a/pkgs/redex/tut-subst.rkt +++ b/pkgs/redex/tut-subst.rkt @@ -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) diff --git a/racket/lib/collects/pkg/lib.rkt b/racket/lib/collects/pkg/lib.rkt index fbd1121219..a3bffa1341 100644 --- a/racket/lib/collects/pkg/lib.rkt +++ b/racket/lib/collects/pkg/lib.rkt @@ -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? diff --git a/racket/lib/collects/racket/HISTORY.txt b/racket/lib/collects/racket/HISTORY.txt index 26efa976fd..73580e2d6e 100644 --- a/racket/lib/collects/racket/HISTORY.txt +++ b/racket/lib/collects/racket/HISTORY.txt @@ -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 diff --git a/racket/lib/collects/setup/option-sig.rkt b/racket/lib/collects/setup/option-sig.rkt index 8dad393247..d9f5b43bf5 100644 --- a/racket/lib/collects/setup/option-sig.rkt +++ b/racket/lib/collects/setup/option-sig.rkt @@ -22,6 +22,8 @@ avoid-main-installation make-tidy make-doc-index + check-dependencies + fix-dependencies call-install call-post-install pause-on-errors diff --git a/racket/lib/collects/setup/option-unit.rkt b/racket/lib/collects/setup/option-unit.rkt index c5edbc612c..31f74de427 100644 --- a/racket/lib/collects/setup/option-unit.rkt +++ b/racket/lib/collects/setup/option-unit.rkt @@ -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) diff --git a/racket/lib/collects/setup/private/pkg-deps.rkt b/racket/lib/collects/setup/private/pkg-deps.rkt new file mode 100644 index 0000000000..5b29faa9c5 --- /dev/null +++ b/racket/lib/collects/setup/private/pkg-deps.rkt @@ -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) stringlist #'(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)))]))) diff --git a/racket/lib/collects/setup/setup-cmdline.rkt b/racket/lib/collects/setup/setup-cmdline.rkt index 3774c8a025..1a5fb2bd09 100644 --- a/racket/lib/collects/setup/setup-cmdline.rkt +++ b/racket/lib/collects/setup/setup-cmdline.rkt @@ -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" diff --git a/racket/lib/collects/setup/setup-unit.rkt b/racket/lib/collects/setup/setup-unit.rkt index 6c990c557b..6aff97a3c3 100644 --- a/racket/lib/collects/setup/setup-unit.rkt +++ b/racket/lib/collects/setup/setup-unit.rkt @@ -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)) diff --git a/racket/src/link-all.rkt b/racket/src/link-all.rkt index d3b744c362..30a565ee68 100644 --- a/racket/src/link-all.rkt +++ b/racket/src/link-all.rkt @@ -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)]