From ecec80fc8ce0a88fdc65a5f1dda66692e3ca53dc Mon Sep 17 00:00:00 2001 From: Jacob Matthews Date: Tue, 22 Apr 2008 23:05:00 +0000 Subject: [PATCH] fix bug in linkage svn: r9412 --- collects/planet/planet.scrbl | 9 ++- collects/planet/planet.ss | 3 +- collects/planet/private/linkage.ss | 94 ++++++++++-------------------- collects/planet/resolver.ss | 42 +++++++------ 4 files changed, 61 insertions(+), 87 deletions(-) diff --git a/collects/planet/planet.scrbl b/collects/planet/planet.scrbl index b5db771dd4..822c641415 100644 --- a/collects/planet/planet.scrbl +++ b/collects/planet/planet.scrbl @@ -478,8 +478,13 @@ installed package.} Holds a listing of all package names and versions installed in the local cache.} -@defparam[current-linkage table ((path-string? (string? natural-number/c natural-number/c) ...) ...)]{ -Gives the current linkage table.} +@defproc[(current-linkage) + ((path-string? (string? (string?) natural-number/c natural-number/c) ...) ...)]{ +Returns the current linkage table. + +The linkage table is an association between file locations (encoded as path strings) +and concrete planet package versions. If a require line in the associated file requests a package, +this table is consulted to determine a particular concrete package to satisfy the request.} @defproc[(make-planet-archive [directory path-string?] [output-file (or/c path? path-string?) (string-append (path->string name) ".plt")]) diff --git a/collects/planet/planet.ss b/collects/planet/planet.ss index f993c94ea6..f0bf8640de 100644 --- a/collects/planet/planet.ss +++ b/collects/planet/planet.ss @@ -232,8 +232,7 @@ This command does not unpack or install the named .plt file." (for-each (lambda (link) (apply printf " ~a\t~a\t~a ~a\n" link)) (cdr module))) - (sort (current-linkage) - (lambda (a b) (stringstring (car a)) (symbol->string (car b))))))) + (sort (current-linkage) (lambda (a b) (string PKG + ; add-linkage! : (resolved-module-path | #f) FULL-PKG-SPEC PKG -> PKG ; unless the first argument is #f, associates the pair of the first two arguments ; with the last in the linkage table. Returns the given package-location - (define (add-linkage! module pkg-spec pkg) - (when (and module (current-module-declare-name)) - (let ((key (get-key module pkg-spec))) + (define (add-linkage! rmp pkg-spec pkg) + (when rmp + (let ((key (get-key rmp pkg-spec))) (hash-table-get (get-linkage-table) key @@ -107,69 +106,36 @@ - ; get-linkage : symbol FULL-PKG-SPEC -> PKG | #f + ; get-linkage : (resolved-module-path | #f) FULL-PKG-SPEC -> PKG | #f ; returns the already-linked module location, or #f if there is none - (define (get-linkage module-specifier pkg-specifier) - (let ((pkg-fields (hash-table-get - (get-linkage-table) - (get-key module-specifier pkg-specifier) - (lambda () #f)))) - (if pkg-fields - (with-handlers ([exn:fail? (lambda (e) #f)]) - (match-let ([(name route maj min pathbytes) pkg-fields]) - (make-pkg name route maj min (bytes->path pathbytes)))) - #f))) + (define (get-linkage rmp pkg-specifier) + (cond + [rmp + (let ((pkg-fields (hash-table-get + (get-linkage-table) + (get-key rmp pkg-specifier) + (lambda () #f)))) + (if pkg-fields + (with-handlers ([exn:fail? (lambda (e) #f)]) + (match-let ([(name route maj min pathbytes) pkg-fields]) + (make-pkg name route maj min (bytes->path pathbytes)))) + #f))] + [else #f])) - ; get-key : symbol FULL-PKG-SPEC -> LINKAGE-KEY + ; get-key : resolved-module-path? FULL-PKG-SPEC -> LINKAGE-KEY ; produces a linkage key for the given pair. - (define (get-key module-specifier pkg-spec) - (list* (get-module-id module-specifier pkg-spec) + (define (get-key rmp pkg-spec) + (list* (get-module-id rmp) (pkg-spec-name pkg-spec) (pkg-spec-maj pkg-spec) (pkg-spec-minor-lo pkg-spec) (pkg-spec-minor-hi pkg-spec) (pkg-spec-path pkg-spec))) - ; get-module-id : TST FULL-PKG-SPEC -> LINKAGE-MODULE-KEY - ; gets a unique identifier naming the module that produced the pkg-spec. - ; (strategy due to Matthew) - (define (get-module-id ms pkg-spec) - (cond - [(full-filename-identifier? ms) - (module-specifier->key ms)] - [(and - (pkg-spec-stx pkg-spec) ;; <-- I don't know about this - (syntax-original? (pkg-spec-stx pkg-spec)) - (path? (syntax-source (pkg-spec-stx pkg-spec)))) - (path->key (desuffix (syntax-source (pkg-spec-stx pkg-spec))))] - [(and (symbol? ms) (current-load-relative-directory)) - (path->key (build-path - (current-load-relative-directory) - (symbol->string ms)))] - [else #f])) + ; get-module-id : resolved-module-path? -> LINKAGE-MODULE-KEY + ; key suitable for marshalling that represents the given resolved-module-path + (define (get-module-id rmp) + (path->string (resolved-module-path-name rmp))) - - ;; ---------------------------------------- - ;; ALL THE BELOW CODE IN THIS SECTION NEEDS - ;; MAJOR MODIFICATION FOR v299 - - ; path? : tst -> bool - ;(define path? string?) - - ; full-filename-identifier? : TST -> bool - ; determines if the given value represents a fully-resolved module identifier - (define (full-filename-identifier? ms) - (and (symbol? ms) - (regexp-match "^\\,.*" (symbol->string ms)))) - - ; module-specifier->key : symbol -> LINKAGE-MODULE-KEY - (define (module-specifier->key ms) - (string->symbol (substring (symbol->string ms) 1))) - - ; path->key : string -> LINKAGE-MODULE-KEY - (define (path->key p) (string->symbol (path->string p))) - - ; desuffix : path -> path - ; removes the suffix from the given file - (define (desuffix file) - (path-replace-suffix file #""))) + ) + diff --git a/collects/planet/resolver.ss b/collects/planet/resolver.ss index 529e9ebc96..73cd3a2c0e 100644 --- a/collects/planet/resolver.ss +++ b/collects/planet/resolver.ss @@ -196,13 +196,17 @@ subdirectory. (define resolver (case-lambda [(name) (void)] + [(spec module-path stx) + (resolver spec module-path stx #t)] [(spec module-path stx load?) ;; ensure these directories exist (make-directory* (PLANET-DIR)) (make-directory* (CACHE-DIR)) (establish-diamond-property-monitor) - (planet-resolve spec module-path stx load?)] - [(spec module-path stx) (resolver spec module-path stx #t)])) + (planet-resolve spec + (current-module-declare-name) ;; seems more reliable than module-path in v3.99 + stx + load?)])) ;; ============================================================================= ;; DIAMOND PROPERTY STUFF @@ -309,13 +313,13 @@ subdirectory. ;; Handles the overall functioning of the resolver ;; ============================================================================= -;; planet-resolve : PLANET-REQUEST symbol syntax[PLANET-REQUEST] -> symbol +;; planet-resolve : PLANET-REQUEST (resolved-module-path | #f) syntax[PLANET-REQUEST] -> symbol ;; resolves the given request. Returns a name corresponding to the module in ;; the correct environment -(define (planet-resolve spec module-path stx load?) - (let-values ([(path pkg) (get-planet-module-path/pkg spec module-path stx)]) +(define (planet-resolve spec rmp stx load?) + (let-values ([(path pkg) (get-planet-module-path/pkg spec rmp stx)]) (when load? (add-pkg-to-diamond-registry! pkg stx)) - (do-require path (pkg-path pkg) module-path stx load?))) + (do-require path (pkg-path pkg) rmp stx load?))) ;; resolve-planet-path : planet-require-spec -> path ;; retrieves the path to the given file in the planet package. downloads and @@ -324,14 +328,14 @@ subdirectory. (let-values ([(path pkg) (get-planet-module-path/pkg spec #f #f)]) path)) -;; get-planet-module-path/pkg :PLANET-REQUEST symbol syntax[PLANET-REQUEST] -> (values path PKG) +;; get-planet-module-path/pkg :PLANET-REQUEST (resolved-module-path | #f) syntax[PLANET-REQUEST] -> (values path PKG) ;; returns the matching package and the file path to the specific request -(define (get-planet-module-path/pkg spec module-path stx) - (request->pkg (spec->req spec stx) module-path stx)) +(define (get-planet-module-path/pkg spec rmp stx) + (request->pkg (spec->req spec stx) rmp stx)) -;; request->pkg : request symbol syntax[PLANET-REQUEST] -> (values path PKG) -(define (request->pkg req module-path stx) - (let* ([result (get-package module-path (request-full-pkg-spec req))]) +;; request->pkg : request (resolved-module-path | #f) syntax[PLANET-REQUEST] -> (values path PKG) +(define (request->pkg req rmp stx) + (let* ([result (get-package rmp (request-full-pkg-spec req))]) (cond [(string? result) (raise-syntax-error 'require result stx)] [(pkg? result) @@ -353,11 +357,11 @@ subdirectory. ;; eventually, and a function that gets to mess with the error message if the ;; entire message eventually fails. -;; get-package : module-path FULL-PKG-SPEC -> (PKG | string) +;; get-package : (resolved-module-path | #f) FULL-PKG-SPEC -> (PKG | string) ;; gets the package specified by pspec requested by the module in the given ;; module path, or returns a descriptive error message string if that's not ;; possible -(define (get-package module-path pspec) +(define (get-package rmp pspec) (let loop ([getters (*package-search-chain*)] [pre-install-updaters '()] [post-install-updaters '()] @@ -375,7 +379,7 @@ subdirectory. ;; try the next error reporter. recursive call is in the failure ;; continuation ((car getters) - module-path + rmp pspec (λ (pkg) (when (uninstalled-pkg? pkg) @@ -396,7 +400,7 @@ subdirectory. ;; ============================================================================= ;; get/installed-cache : pkg-getter -(define (get/installed-cache module-spec pkg-spec success-k failure-k) +(define (get/installed-cache _ pkg-spec success-k failure-k) (let ([p (lookup-package pkg-spec)]) (if p (success-k p) (failure-k void void (λ (x) x))))) @@ -407,13 +411,13 @@ subdirectory. ;; get/uninstalled-cache-dummy : pkg-getter ;; always fails, but records the package to the uninstalled package cache upon ;; the success of some other getter later in the chain. -(define (get/uninstalled-cache-dummy module-spec pkg-spec success-k failure-k) +(define (get/uninstalled-cache-dummy _ pkg-spec success-k failure-k) (failure-k save-to-uninstalled-pkg-cache! void (λ (x) x))) ;; get/uninstalled-cache : pkg-getter ;; note: this does not yet work with minimum-required-version specifiers if you ;; install a package and then use an older mzscheme -(define (get/uninstalled-cache module-spec pkg-spec success-k failure-k) +(define (get/uninstalled-cache _ pkg-spec success-k failure-k) (let ([p (lookup-package pkg-spec (UNINSTALLED-PACKAGE-CACHE))]) (if (and p (file-exists? (build-path (pkg-path p) (pkg-spec-name pkg-spec)))) @@ -457,7 +461,7 @@ subdirectory. ;; locally. ;; ============================================================================= -(define (get/server module-spec pkg-spec success-k failure-k) +(define (get/server _ pkg-spec success-k failure-k) (let ([p (get-package-from-server pkg-spec)]) (cond [(pkg-promise? p) (success-k p)]