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

fix problem with path->collects-relative

Browse Source 
An internal error could be triggered by a path immediately
inside the "pkgs" directory.
This commit is contained in:
Matthew Flatt 2013-12-30 09:32:03 -07:00
parent e44b15c032
commit b3ab82c5f9
3 changed files with 15 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,5 +1,6 @@
#lang racket/base #lang racket/base
(require pkg/path) (require pkg/path
setup/dirs)
(module+ test (module+ test
(require rackunit) (require rackunit)
@ -18,6 +19,9 @@
(check-equal? (path->pkg (find-system-path 'temp-dir)) (check-equal? (path->pkg (find-system-path 'temp-dir))
#f) #f)
(check-equal? (path->pkg (build-path (find-pkgs-dir) "pkgs.rktd"))
#f)
(check-equal? (call-with-values (check-equal? (call-with-values
(lambda () (path->pkg+subpath+collect (collection-file-path "serve-catalog.rkt" "distro-build"))) (lambda () (path->pkg+subpath+collect (collection-file-path "serve-catalog.rkt" "distro-build")))
list) list)

16
racket/collects/pkg/path.rkt
View File

@ -111,13 +111,15 @@
;; name followed by "+<n>") ;; name followed by "+<n>")
(define len (length d)) (define len (length d))
(define pkg-name (path-element->string (list-ref p len))) (define pkg-name (path-element->string (list-ref p len)))
(values (if (regexp-match? #rx"[+]" pkg-name) ; +<n> used as an alternate path, sometimes (if (regexp-match? #rx"pkgs[.]rktd" pkg-name)
(regexp-replace #rx"[+].*$" pkg-name "") (values #f #f #f) ; don't count the database as a package
pkg-name) (values (if (regexp-match? #rx"[+]" pkg-name) ; +<n> used as an alternate path, sometimes
(build-path* (list-tail p (add1 len))) (regexp-replace #rx"[+].*$" pkg-name "")
(and want-collect? pkg-name)
(let ([i (hash-ref (read-pkg-db/cached) pkg-name #f)]) (build-path* (list-tail p (add1 len)))
(and i (sc-pkg-info? i) (sc-pkg-info-collect i)))))] (and want-collect?
(let ([i (hash-ref (read-pkg-db/cached) pkg-name #f)])
(and i (sc-pkg-info? i) (sc-pkg-info-collect i))))))]
[else [else
;; Maybe it's a linked package ;; Maybe it's a linked package
(define pkgs-dir (get-pkgs-dir scope)) (define pkgs-dir (get-pkgs-dir scope))

2
racket/collects/setup/collects.rkt
View File

@ -21,7 +21,7 @@
(define-values (pkg subpath pkg-collect) (define-values (pkg subpath pkg-collect)
(path->pkg+subpath+collect simple-p #:cache cache)) (path->pkg+subpath+collect simple-p #:cache cache))
(cond (cond
[pkg [(and pkg (not (eq? 'same subpath)))
(define p-l (map path-element->string (reverse (explode-path subpath)))) (define p-l (map path-element->string (reverse (explode-path subpath))))
(define new-c-l (let ([l (reverse (cdr p-l))]) (define new-c-l (let ([l (reverse (cdr p-l))])
(if pkg-collect (if pkg-collect