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

raco pkg: fix handling of overlapping provided-package sets

Browse Source
This commit is contained in:
Matthew Flatt 2013-07-01 13:17:18 -06:00
parent 038d423315
commit 81f29602d0
7 changed files with 79 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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.

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

@ -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"

2
pkgs/racket-pkgs/racket-test/tests/pkg/tests-overwrite.rkt
View File

@ -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"

3
pkgs/racket-pkgs/racket-test/tests/pkg/tests-remove.rkt
View File

@ -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"

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

@ -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 _)

28
racket/lib/collects/setup/private/setup-relative.rkt
View File

@ -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 "<collects>/")
(cons find-user-collects-dir "<user>/")
(cons find-planet-dir "<planet>/"))
(lambda (x)
(define-values (pkg sub) (path->pkg+subpath x))
(cond
[pkg
(string-append "<pkgs>" "/" 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 "<collects>/")
(cons find-user-collects-dir "<user>/")
(cons find-planet-dir "<planet>/"))
(lambda (x)
(define-values (pkg sub) (path->pkg+subpath x #:cache (current-cache)))
(cond
[pkg
(string-append "<pkgs>" "/" 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)))))

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

@ -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