From 2b8e2efbb81836dd1f7e4fb271b8a5535ad986f4 Mon Sep 17 00:00:00 2001 From: Jacob Matthews Date: Mon, 23 Jan 2006 21:54:13 +0000 Subject: [PATCH] . svn: r1935 --- collects/planet/private/planet-shared.ss | 156 ++++++++++------------- collects/planet/resolver.ss | 23 ++-- collects/planet/util.ss | 4 +- 3 files changed, 87 insertions(+), 96 deletions(-) diff --git a/collects/planet/private/planet-shared.ss b/collects/planet/private/planet-shared.ss index b6006e1d67..81921ea886 100644 --- a/collects/planet/private/planet-shared.ss +++ b/collects/planet/private/planet-shared.ss @@ -44,7 +44,7 @@ Various common pieces of code that both the client and server need to access ; or #f if the given package isn't in the cache or the hardlink table (define (lookup-package pkg) (let* ((at (build-assoc-table pkg))) - (get-best-match/t at pkg))) + (get-best-match at pkg))) ; build-assoc-table : FULL-PKG-SPEC -> assoc-table ; returns a version-number -> directory association table for the given package @@ -65,7 +65,18 @@ Various common pieces of code that both the client and server need to access (let ((maj (string->number majs)) (min (string->number mins))) (if (and (path? p) maj min) - (list (pkg-spec-name pkg) (pkg-spec-path pkg) maj min (build-path path majs mins)) + (let* ((the-path (build-path path majs mins)) + (minimum-core-version + (if (file-exists? (build-path the-path "minimum-core-version")) + (with-input-from-file (build-path the-path "minimum-core-version") + read-line) + #f))) + (make-assoc-table-row + (pkg-spec-name pkg) + (pkg-spec-path pkg) + maj min + the-path + minimum-core-version)) #f))) (if (directory-exists? path) @@ -135,7 +146,7 @@ Various common pieces of code that both the client and server need to access (define (add-hard-link! name path maj min dir) (let* ([original-table (get-hard-link-table)] [new-table (cons - (list name path maj min dir) + (make-assoc-table-row name path maj min dir #f) (filter (lambda (row) (not (points-to? row name path maj min))) original-table))]) @@ -162,37 +173,72 @@ Various common pieces of code that both the client and server need to access (define (first-n-list-selectors n) (apply values (build-list n (lambda (m) (lambda (row) (list-ref row m)))))) - ;; assoc-table-row->{name,path,maj,min,dir} : assoc-table-row -> {string,(listof string),num,num,path} - ;; retrieve the {package name, "package path", major version, minor version, directory} + ;; assoc-table-row->{name,path,maj,min,dir,required-version} + ;; : assoc-table-row -> + ;; {string,(listof string),num,num,path,string|#f} + ;; retrieve the {package name, "package path", major version, minor version, directory, required core version} ;; of the given row (define-values (assoc-table-row->name assoc-table-row->path assoc-table-row->maj assoc-table-row->min - assoc-table-row->dir) - (first-n-list-selectors 5)) + assoc-table-row->dir + assoc-table-row->required-version) + (first-n-list-selectors 6)) - ; get-best-match/t : assoc-table FULL-PKG-SPEC -> PKG | #f - (define (get-best-match/t table spec) + (define (make-assoc-table-row name path maj min dir required-version) + (list name path maj min dir required-version)) + + (define-struct mz-version (major minor)) + + ;; string->mz-version : string -> mz-version | #f + (define (string->mz-version str) + (let ((ver (regexp-match #rx"^([0-9]+)(\\.([0-9]+))?$" str))) + (if ver + (make-mz-version (list-ref ver 1) (list-ref ver 3)) + #f))) + + ;; version<= : mz-version mz-version -> boolean + ;; determines if a is the version string of an earlier mzscheme release than b + ;; [n.b. this relies on a guarantee from Matthew that mzscheme version + ;; x1.y1 is older than version x2.y2 iff x1 boolean + ;; determines if the given package constrint verstr can support the given package + (define (compatible-version? row spec) + (let ((required-version (assoc-table-row->required-version row))) + (or (not required-version) + (version<= (string->mz-version required-version) + (string->mz-version (pkg-spec-core-version spec)))))) + + ; get-best-match : assoc-table FULL-PKG-SPEC -> PKG | #f + ; return the best on-disk match for the given package spec + (define (get-best-match table spec) (let* ((target-maj (or (pkg-spec-maj spec) (apply max (map assoc-table-row->maj table)))) - (maj-matches (filter (λ (x) (equal? target-maj (assoc-table-row->maj x))) table)) - (in-min-range - (let ((lo (pkg-spec-minor-lo spec)) - (hi (pkg-spec-minor-hi spec))) - (filter - (λ (x) - (let ((n (assoc-table-row->min x))) - (and (or (not lo) (>= n lo)) - (or (not hi) (<= n hi))))) - maj-matches)))) - (if (null? in-min-range) + (lo (pkg-spec-minor-lo spec)) + (hi (pkg-spec-minor-hi spec)) + (matches + (filter + (λ (x) + (let ((n (assoc-table-row->min x))) + (and + (equal? target-maj (assoc-table-row->maj x)) + (or (not lo) (>= n lo)) + (or (not hi) (<= n hi)) + (compatible-version? x spec)))) + table))) + (if (null? matches) #f (let ((best-row (car (quicksort - in-min-range + matches (λ (a b) (> (assoc-table-row->min a) (assoc-table-row->min b))))))) (make-pkg (pkg-spec-name spec) @@ -200,53 +246,9 @@ Various common pieces of code that both the client and server need to access (assoc-table-row->maj best-row) (assoc-table-row->min best-row) (assoc-table-row->dir best-row)))))) - - ; get-best-match : FULL-PKG-SPEC (listof string[directory-name]) -> PKG | #f - ; gets the best version in the given subdirectory in the specified low and high version range - ; or #f if there is no appropriate version - (define (get-best-match pkg-spec path) - (let ((major-version (if (pkg-spec-maj pkg-spec) - (let ((specified-number (number->string (pkg-spec-maj pkg-spec)))) - (if (directory-exists? (build-path path specified-number)) - specified-number - #f)) - (get-highest-numbered-subdir path #f #f)))) - (if major-version - (let ((minor-version (get-highest-numbered-subdir - (build-path path major-version) - (pkg-spec-minor-lo pkg-spec) - (pkg-spec-minor-hi pkg-spec)))) - (if minor-version - (make-pkg - (pkg-spec-name pkg-spec) - (pkg-spec-path pkg-spec) - (string->number major-version) - (string->number minor-version) - (build-path path major-version minor-version)) - #f)) - #f))) - - ; get-highest-numbered-subdir : string (Nat | #f) (Nat | #f) -> string[subdir] | #f - ; given a path, returns the subdirectory of that path with the highest numeric name or #f if - ; none exists. Does not return the full path. - (define (get-highest-numbered-subdir path lo hi) - (define (valid-dir? d) - (and - (directory-exists? (build-path path d)) - (let ((n (string->number (path->string d)))) - (and n - (or (not lo) (>= n lo)) - (or (not hi) (<= n hi)))))) - - (unless (directory-exists? path) - (raise (make-exn:fail:filesystem - "Internal PLaneT error: inconsistent cache, directory does not exist" - (current-continuation-marks)))) - (max-string (map path->string (filter valid-dir? (directory-list path))))) - - ; FULL-PKG-SPEC : (make-pkg-spec string (Nat | #f) (Nat | #f) (Nat | #f) (listof string) (syntax | #f)) - (define-struct pkg-spec (name maj minor-lo minor-hi path stx) (make-inspector)) + ; FULL-PKG-SPEC : (make-pkg-spec string (Nat | #f) (Nat | #f) (Nat | #f) (listof string) (syntax | #f)) string + (define-struct pkg-spec (name maj minor-lo minor-hi path stx core-version) (make-inspector)) ; PKG : string Nat Nat path (define-struct pkg (name route maj min path)) @@ -281,24 +283,6 @@ Various common pieces of code that both the client and server need to access #f void)))) - ; max-string : listof string[digits] -> string | #f - ; this odd little guy takes a list of strings that represent a number and returns the string - ; that represents the maximum number among them, or #f if there were no numbers at all - (define (max-string strs) - (if (null? strs) - #f - (let loop ((biggest (car strs)) - (big-n (string->number (car strs))) - (rest (cdr strs))) - (cond - [(null? rest) biggest] - [else - (let* ([candidate (car rest)] - [test-n (string->number candidate)]) - (if (> test-n big-n) - (loop candidate test-n (cdr rest)) - (loop biggest big-n (cdr rest))))])))) - ; write-line : X output-port -> void ; writes the given value followed by a newline to the given port (define (write-line obj p) @@ -465,4 +449,4 @@ Various common pieces of code that both the client and server need to access ;; tree->list : tree[x] -> sexp-tree[x] (define (tree->list tree) - (cons (branch-node tree) (map tree->list (branch-children tree))))) \ No newline at end of file + (cons (branch-node tree) (map tree->list (branch-children tree))))) diff --git a/collects/planet/resolver.ss b/collects/planet/resolver.ss index cd52f363ab..5d3940245c 100644 --- a/collects/planet/resolver.ss +++ b/collects/planet/resolver.ss @@ -230,6 +230,14 @@ attempted to load version ~a.~a while version ~a.~a was already loaded" (define (get-planet-module-path/pkg spec module-path stx) (match (cdr spec) [(file-name pkg-spec path ...) + (unless (string? file-name) + (raise-syntax-error #f (format "File name: expected a string, received: ~s" file-name) stx)) + (unless (andmap string? path) + ;; special-case to catch a possibly common error: + (if (ormap number? path) + (raise-syntax-error #f (format "Module path must consist of strings only, received a number (maybe you intended to specify a package version number?): ~s" path) stx) + (raise-syntax-error #f (format "Module path must consist of strings only, received: ~s" path) stx))) + (match-let* ([pspec (pkg-spec->full-pkg-spec pkg-spec stx)] [pkg (or (get-linkage module-path pspec) @@ -237,20 +245,19 @@ attempted to load version ~a.~a while version ~a.~a was already loaded" (or (get-package-from-cache pspec) (get-package-from-server pspec) - (raise-syntax-error #f (format "Could not find package matching ~s" (list (pkg-spec-name pspec) - (pkg-spec-maj pspec) - (list (pkg-spec-minor-lo pspec) - (pkg-spec-minor-hi pspec)) - (pkg-spec-path pspec))) + (raise-syntax-error #f (format "Could not find package matching ~s" + (list (pkg-spec-name pspec) + (pkg-spec-maj pspec) + (list (pkg-spec-minor-lo pspec) + (pkg-spec-minor-hi pspec)) + (pkg-spec-path pspec))) stx))))]) (values (apply build-path (pkg-path pkg) (append path (list file-name))) pkg))] [_ (raise-syntax-error 'require (format "Illegal PLaneT invocation: ~e" (cdr spec)) stx)])) - ;; get-path : planet-request -> path - ; pkg-spec->full-pkg-spec : PKG-SPEC syntax -> FULL-PKG-SPEC (define (pkg-spec->full-pkg-spec spec stx) - (define (pkg name maj lo hi path) (make-pkg-spec name maj lo hi path stx)) + (define (pkg name maj lo hi path) (make-pkg-spec name maj lo hi path stx (version))) (match spec [(? string?) (pkg spec #f #f #f '())] [((? string? path) ...) (pkg (last path) #f 0 #f (drop-last path))] diff --git a/collects/planet/util.ss b/collects/planet/util.ss index b628e2b5b8..f90cbaec8c 100644 --- a/collects/planet/util.ss +++ b/collects/planet/util.ss @@ -30,9 +30,9 @@ (cdr (tree->list (repository-tree)))) ;; get-installed-package : string string nat nat -> PKG | #f - ;; gets the package associated with this package, if any + ;; gets the package associated with this package specification, if any (define (get-installed-package owner name maj min) - (lookup-package (make-pkg-spec name maj min min (list owner) #f))) + (lookup-package (make-pkg-spec name maj min min (list owner) #f (version)))) ;; just so it will be provided (define unlink-all remove-all-linkage!)