From 81f29602d0cfcb78e1a6697f4b74e27f17940c83 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 1 Jul 2013 13:17:18 -0600 Subject: [PATCH] raco pkg: fix handling of overlapping provided-package sets --- .../racket-doc/pkg/scribblings/pkg.scrbl | 4 +- .../racket-test/tests/pkg/tests-install.rkt | 6 +++ .../racket-test/tests/pkg/tests-overwrite.rkt | 2 +- .../racket-test/tests/pkg/tests-remove.rkt | 3 ++ racket/lib/collects/pkg/lib.rkt | 53 ++++++++++++++----- .../collects/setup/private/setup-relative.rkt | 28 ++++++---- racket/lib/collects/setup/setup-unit.rkt | 16 ++++-- 7 files changed, 79 insertions(+), 33 deletions(-) diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl index 31c3e2d36f..ebfc4e7ddf 100644 --- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl +++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl @@ -284,7 +284,7 @@ sub-sub-commands: @itemlist[ @item{@command/toc{install} @nonterm{option} ... @nonterm{pkg-source} ... - --- Installs the given @tech{package sources} with the given + --- Installs the given @tech{package sources} (eliminating exact-duplicate @nonterm{pkg-source}s) with the given @nonterm{option}s: @itemlist[ @@ -365,7 +365,7 @@ this command fails without installing any of the @nonterm{pkg}s } @item{@command/toc{remove} @nonterm{option} ... @nonterm{pkg} ... ---- Attempts to remove the given packages. If a package is the dependency +--- Attempts to remove the given packages. By default, if a package is the dependency of another package that is not listed, this command fails without removing any of the @nonterm{pkg}s. 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 e767e30556..1480659cdb 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-install.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-install.rkt @@ -86,6 +86,12 @@ "pkg-test1 pkg-test3" $ "racket -e '(require pkg-test3)'") + (shelly-install "redundant packages ignored" "test-pkgs/pkg-test1/ test-pkgs/pkg-test1/" + $ "racket -e '(require pkg-test1)'") + (shelly-case + "conflicting package names disallowed" + $ "raco pkg install test-pkgs/pkg-test1/ test-pkgs/pkg-test1.zip" =exit> 1) + (with-fake-root (shelly-case "linking local directory" diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-overwrite.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-overwrite.rkt index 7f7e49d66b..b2f11a859e 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-overwrite.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-overwrite.rkt @@ -8,7 +8,7 @@ "The installation directory is not touched until a package can definitely be installed AND one fail reverts the whole install" ;; Step 1. Try to install a package that will fail - $ "raco pkg install test-pkgs/pkg-test1.zip test-pkgs/pkg-test1.zip" + $ "raco pkg install test-pkgs/pkg-test1.zip test-pkgs/pkg-test1-conflict.zip" =exit> 1 =stderr> #rx"packages conflict" diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-remove.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-remove.rkt index fff47de606..72da6d4ba3 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-remove.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-remove.rkt @@ -24,6 +24,9 @@ $ "raco pkg remove not-there" =exit> 1) (shelly-install "remove test" "test-pkgs/pkg-test1.zip") + (shelly-install "remove test with immediately redundant package name" + "test-pkgs/pkg-test1.zip" + "pkg-test1 pkg-test1") (shelly-install "remove of dep fails" "test-pkgs/pkg-test1.zip" $ "raco pkg show -u" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1 +[a-f0-9]+ +\\(file .+tests/pkg/test-pkgs/pkg-test1.zip\\)\n" diff --git a/racket/lib/collects/pkg/lib.rkt b/racket/lib/collects/pkg/lib.rkt index 92b9d0ad04..616bb9ed99 100644 --- a/racket/lib/collects/pkg/lib.rkt +++ b/racket/lib/collects/pkg/lib.rkt @@ -58,6 +58,13 @@ (exn-message x))) (struct pkg-desc (source type name auto?)) +(define (pkg-desc=? a b) + (define (->list a) + (list (pkg-desc-source a) + (pkg-desc-type a) + (pkg-desc-name a) + (pkg-desc-auto? a))) + (equal? (->list a) (->list b))) (define (path->bytes* pkg) (cond @@ -700,7 +707,7 @@ (loop still-drop (set-union keep delta))))) ;; just given pkgs: - in-pkgs)) + (remove-duplicates in-pkgs))) (define setup-collects (get-setup-collects (filter-map (lambda (p) (define dir (pkg-directory* p)) @@ -1339,6 +1346,20 @@ (stage-package/info (pkg-desc-source v) (pkg-desc-type v) (pkg-desc-name v) check-sums? download-printf metadata-ns))) + ;; For the top-level call, we need to double-check that all provided packages + ;; were distinct: + (for/fold ([ht (hash)]) ([i (in-list infos)] + [desc (in-list descs)]) + (define name (install-info-name i)) + (when (hash-ref ht name #f) + (pkg-error (~a "given package sources have the same package name\n" + " package name: ~a\n" + " package source: ~a\n" + " package source: ~a") + name + (pkg-desc-source (hash-ref ht name #f)) + (pkg-desc-source desc))) + (hash-set ht name desc)) (define setup-collects (get-setup-collects (map (lambda (i) (cons (install-info-name i) @@ -1415,12 +1436,27 @@ #:dep-behavior [dep-behavior #f] #:updating? [updating? #f] #:quiet? [quiet? #f]) + (define new-descs + (remove-duplicates + (if (not skip-installed?) + descs + (let ([db (read-pkg-db)]) + (filter (lambda (d) + (define pkg-name + (or (pkg-desc-name d) + (let-values ([(name type) + (package-source->name+type (pkg-desc-source d) + (pkg-desc-type d))]) + name))) + (not (hash-ref db pkg-name #f))) + descs))) + pkg-desc=?)) (with-handlers* ([vector? (match-lambda [(vector updating? new-infos deps more-pre-succeed) (pkg-install #:old-infos new-infos - #:old-auto+pkgs (append old-descs descs) + #:old-auto+pkgs (append old-descs new-descs) #:force? force #:ignore-checksums? ignore-checksums? #:dep-behavior dep-behavior @@ -1438,18 +1474,7 @@ #:pre-succeed pre-succeed #:updating? updating? #:quiet? quiet? - (if (not skip-installed?) - descs - (let ([db (read-pkg-db)]) - (filter (lambda (d) - (define pkg-name - (or (pkg-desc-name d) - (let-values ([(name type) - (package-source->name+type (pkg-desc-source d) - (pkg-desc-type d))]) - name))) - (not (hash-ref db pkg-name #f))) - descs)))))) + new-descs))) (define (update-is-possible? pkg-name) (match-define (pkg-info orig-pkg checksum _) diff --git a/racket/lib/collects/setup/private/setup-relative.rkt b/racket/lib/collects/setup/private/setup-relative.rkt index 61ff9eebdf..18beb8e73f 100644 --- a/racket/lib/collects/setup/private/setup-relative.rkt +++ b/racket/lib/collects/setup/private/setup-relative.rkt @@ -8,14 +8,20 @@ (provide path->relative-string/setup/pkg) (define path->relative-string/setup/pkg - (make-path->relative-string - (list (cons find-collects-dir "/") - (cons find-user-collects-dir "/") - (cons find-planet-dir "/")) - (lambda (x) - (define-values (pkg sub) (path->pkg+subpath x)) - (cond - [pkg - (string-append "" "/" pkg "/" (if (eq? sub 'same) "" (path->string sub)))] - [(path? x) (path->string x)] - [else x])))) + (let () + (define current-cache (make-parameter #f)) + (define p->r + (make-path->relative-string + (list (cons find-collects-dir "/") + (cons find-user-collects-dir "/") + (cons find-planet-dir "/")) + (lambda (x) + (define-values (pkg sub) (path->pkg+subpath x #:cache (current-cache))) + (cond + [pkg + (string-append "" "/" pkg "/" (if (eq? sub 'same) "" (path->string sub)))] + [(path? x) (path->string x)] + [else x])))) + (lambda (x #:cache [cache #f]) + (parameterize ([current-cache cache]) + (p->r x))))) diff --git a/racket/lib/collects/setup/setup-unit.rkt b/racket/lib/collects/setup/setup-unit.rkt index cca26cd781..b479ec400a 100644 --- a/racket/lib/collects/setup/setup-unit.rkt +++ b/racket/lib/collects/setup/setup-unit.rkt @@ -203,6 +203,8 @@ ;; Find Collections ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (define pkg-path-cache (make-hash)) + (define (make-cc* collection parent path omit-root info-root info-path info-path-mode shadowing-policy main?) @@ -217,7 +219,7 @@ (error name-sym "'name' result from collection ~e is not a string: ~e" path x))))) - (define path-name (path->relative-string/setup/pkg path)) + (define path-name (path->relative-string/setup/pkg path #:cache pkg-path-cache)) (when (info 'compile-subcollections (lambda () #f)) (setup-printf "WARNING" "ignoring `compile-subcollections' entry in info ~a" @@ -643,7 +645,8 @@ (unless printed? (set! printed? #t) (setup-printf "deleting" "in ~a" - (path->relative-string/setup/pkg (cc-path cc))))) + (path->relative-string/setup/pkg (cc-path cc) + #:cache pkg-path-cache)))) (for ([path paths]) (define full-path (build-path (cc-path cc) path)) (when (or (file-exists? full-path) (directory-exists? full-path)) @@ -691,7 +694,7 @@ (define dep (build-path dir mode-dir (path-add-suffix name #".dep"))) (when (and (file-exists? dep) (file-exists? zo)) (set! did-something? #t) - (setup-printf "deleting" "~a" (path->relative-string/setup/pkg zo)) + (setup-printf "deleting" "~a" (path->relative-string/setup/pkg zo #:cache pkg-path-cache)) (delete-file/record-dependency zo dependencies) (delete-file/record-dependency dep dependencies)))) (when did-something? (loop dependencies))) @@ -841,7 +844,8 @@ (set! gcs 2) (setup-fprintf p #f " in ~a" (path->relative-string/setup/pkg - (path->complete-path where (cc-path cc))))) + (path->complete-path where (cc-path cc)) + #:cache pkg-path-cache))) (lambda () (define dir (cc-path cc)) (define info (cc-info cc)) @@ -1055,7 +1059,9 @@ (define-values [base name dir?] (split-path info-path)) (make-directory* base) (define p info-path) - (setup-printf "updating" "~a" (path->relative-string/setup/pkg p)) + (setup-printf "updating" "~a" (path->relative-string/setup/pkg + p + #:cache pkg-path-cache)) (when (verbose) (define ht0 (hash-ref ht-orig info-path)) (when ht0