fix bug in linkage
svn: r9412
This commit is contained in:
Jacob Matthews
parent
2f9a7fc819
commit
ecec80fc8c
|
|
@ -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")])
|
||||
|
|
|
|||
|
|
@ -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) (string<? (symbol->string (car a)) (symbol->string (car b)))))))
|
||||
(sort (current-linkage) (lambda (a b) (string<? (car a) (car b))))))
|
||||
|
||||
(define (add-hard-link-cmd ownerstr pkgstr majstr minstr pathstr)
|
||||
(let* ([maj (read-from-string majstr)]
|
||||
|
|
|
|||
|
|
@ -2,7 +2,6 @@
|
|||
|
||||
(require "planet-shared.ss"
|
||||
"../config.ss"
|
||||
mzlib/file
|
||||
mzlib/match)
|
||||
|
||||
(provide get/linkage
|
||||
|
|
@ -19,13 +18,13 @@
|
|||
|
||||
;; get/linkage : pkg-getter [see ../resolver.ss]
|
||||
;; getter for the linkage table
|
||||
(define (get/linkage module-specifier pkg-specifier success-k failure-k)
|
||||
(let ([linked-pkg (get-linkage module-specifier pkg-specifier)])
|
||||
(define (get/linkage rmp pkg-specifier success-k failure-k)
|
||||
(let ([linked-pkg (get-linkage rmp pkg-specifier)])
|
||||
(if linked-pkg
|
||||
(success-k linked-pkg)
|
||||
(failure-k
|
||||
void
|
||||
(λ (pkg) (add-linkage! module-specifier pkg-specifier pkg))
|
||||
(λ (pkg) (add-linkage! rmp pkg-specifier pkg))
|
||||
(λ (x) x)))))
|
||||
|
||||
|
||||
|
|
@ -45,12 +44,12 @@
|
|||
(unless LT (set! LT (build-hash-table (with-input-from-file (LINKAGE-FILE) read-all))))
|
||||
LT)
|
||||
|
||||
; add-linkage! : (symbol | #f) FULL-PKG-SPEC PKG -> 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 #"")))
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user