From 34dc76bd054332b728434864c3119f9726f1f624 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 3 Sep 2014 10:53:28 -0400 Subject: [PATCH] Revert "Fix PR14692" This reverts commit 92d5408aa87043916644ec68d05b18cee2d21f69, because it breaks the build due to recursive deps. (It also breaks if the core is in the "racket" package.) --- .../racket-test/tests/pkg/path.rkt | 7 -- racket/collects/pkg/path.rkt | 113 ++++++++---------- 2 files changed, 50 insertions(+), 70 deletions(-) diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/path.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/path.rkt index 22f3ab6307..4019a07541 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/path.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/path.rkt @@ -1,17 +1,10 @@ #lang racket/base (require pkg/path - syntax/modresolve setup/dirs) (module+ test (require rackunit) - (check-equal? (path->pkg (resolve-module-path 'typed/racket #f)) - "typed-racket-lib") - - (check-equal? (path->pkg (resolve-module-path 'racket #f)) - "base") - (check-equal? (path->pkg (collection-file-path "path.rkt" "tests" "pkg")) "racket-test") (check-equal? (call-with-values diff --git a/racket/collects/pkg/path.rkt b/racket/collects/pkg/path.rkt index db52962d6a..c19934cd03 100644 --- a/racket/collects/pkg/path.rkt +++ b/racket/collects/pkg/path.rkt @@ -69,9 +69,6 @@ [orig-pkg `(catalog ,(cadr (pkg-info-orig-pkg v)))]) v))))) -(define (mbind m f) - (and m (f m))) - (define (path->pkg+subpath+collect* who given-p cache want-collect?) (unless (path-string? given-p) (raise-argument-error who "path-string?" given-p)) @@ -91,72 +88,62 @@ (define p (explode given-p)) (define (build-path* l) (if (null? l) 'same (apply build-path l))) - (define cdp (mbind (find-collects-dir) explode)) - (cond - [(and cdp (sub-path? < p cdp)) - (define len (length cdp)) - ;; This might need to be something else in the future, if base - ;; gets smaller - (values "base" - (build-path* (list-tail p (add1 len))) - #f)] - [else - (for/fold ([pkg #f] [subpath #f] [collect #f]) - ([scope (in-list (list* 'user - (get-pkgs-search-dirs)))] - #:when (not pkg)) - (define d (or (and cache - (hash-ref cache `(dir ,scope) #f)) - (let ([d (explode (get-pkgs-dir scope))]) - (when cache (hash-set! cache `(dir ,scope) d)) - d))) - (define (read-pkg-db/cached) - (or (and cache - (hash-ref cache `(db ,scope) #f)) - (let ([db (read-pkgs-db scope)]) - (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 (or the package - ;; name followed by "+") - (define len (length d)) - (define pkg-name (path-element->string (list-ref p len))) - (if (regexp-match? #rx"pkgs[.]rktd" pkg-name) - (values #f #f #f) ; don't count the database as a package - (values (if (regexp-match? #rx"[+]" pkg-name) ; + used as an alternate path, sometimes + (for/fold ([pkg #f] [subpath #f] [collect #f]) + ([scope (in-list (list* 'user + (get-pkgs-search-dirs)))] + #:when (not pkg)) + (define d (or (and cache + (hash-ref cache `(dir ,scope) #f)) + (let ([d (explode (get-pkgs-dir scope))]) + (when cache (hash-set! cache `(dir ,scope) d)) + d))) + (define (read-pkg-db/cached) + (or (and cache + (hash-ref cache `(db ,scope) #f)) + (let ([db (read-pkgs-db scope)]) + (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 (or the package + ;; name followed by "+") + (define len (length d)) + (define pkg-name (path-element->string (list-ref p len))) + (if (regexp-match? #rx"pkgs[.]rktd" pkg-name) + (values #f #f #f) ; don't count the database as a package + (values (if (regexp-match? #rx"[+]" pkg-name) ; + used as an alternate path, sometimes (regexp-replace #rx"[+].*$" pkg-name "") pkg-name) - (build-path* (list-tail p (add1 len))) - (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 - ;; Maybe it's a linked package - (define pkgs-dir (get-pkgs-dir scope)) - (for/fold ([pkg #f] [subpath #f] [collect #f]) - ([(k v) (in-hash (read-pkg-db/cached))] - #:when (not pkg)) - (define orig (pkg-info-orig-pkg v)) - (if (and (pair? orig) - (or (eq? 'link (car orig)) - (eq? 'static-link (car orig)))) - (let ([e (or (and cache - (hash-ref cache `(pkg-dir ,(cadr orig)) #f)) - (let ([e (explode (simplify-path - (path->complete-path (cadr orig) pkgs-dir) - #f))]) - (when cache - (hash-set! cache `(pkg-dir ,(cadr orig)) e)) - e))]) - (if (sub-path? <= p e) + (build-path* (list-tail p (add1 len))) + (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 + ;; Maybe it's a linked package + (define pkgs-dir (get-pkgs-dir scope)) + (for/fold ([pkg #f] [subpath #f] [collect #f]) + ([(k v) (in-hash (read-pkg-db/cached))] + #:when (not pkg)) + (define orig (pkg-info-orig-pkg v)) + (if (and (pair? orig) + (or (eq? 'link (car orig)) + (eq? 'static-link (car orig)))) + (let ([e (or (and cache + (hash-ref cache `(pkg-dir ,(cadr orig)) #f)) + (let ([e (explode (simplify-path + (path->complete-path (cadr orig) pkgs-dir) + #f))]) + (when cache + (hash-set! cache `(pkg-dir ,(cadr orig)) e)) + e))]) + (if (sub-path? <= p e) (values k (build-path* (list-tail p (length e))) (and (sc-pkg-info? v) (sc-pkg-info-collect v))) (values #f #f #f))) - (values #f #f #f)))]))])) + (values #f #f #f)))]))) (define (path->pkg+subpath+collect given-p #:cache [cache #f]) (path->pkg+subpath+collect* 'path->pkg+subpath+collect given-p cache #t))