diff --git a/collects/planet/cachepath.ss b/collects/planet/cachepath.ss index 1772533f7b..4d10767772 100644 --- a/collects/planet/cachepath.ss +++ b/collects/planet/cachepath.ss @@ -1,4 +1,4 @@ -(module cachepath mzscheme +#lang scheme/base (require "config.ss") (provide get-planet-cache-path) @@ -11,4 +11,4 @@ ;; of directory, it doesn't do that anymore) (define (get-planet-cache-path) (let ((path (build-path (PLANET-DIR) "cache.ss"))) - path))) + path)) diff --git a/collects/planet/config.ss b/collects/planet/config.ss index 77d3592e86..ee22fb18ca 100644 --- a/collects/planet/config.ss +++ b/collects/planet/config.ss @@ -1,4 +1,5 @@ -(module config mzscheme +#lang scheme/base + (require "private/define-config.ss") (define-parameters (PLANET-SERVER-NAME "planet.plt-scheme.org") @@ -20,5 +21,4 @@ (USE-HTTP-DOWNLOADS? #t) (HTTP-DOWNLOAD-SERVLET-URL "http://planet.plt-scheme.org/servlets/planet-servlet.ss") - (PLANET-ARCHIVE-FILTER #f))) - + (PLANET-ARCHIVE-FILTER #f)) diff --git a/collects/planet/planet-archives.ss b/collects/planet/planet-archives.ss index dd8480a3cd..b39dfc1c26 100644 --- a/collects/planet/planet-archives.ss +++ b/collects/planet/planet-archives.ss @@ -1,6 +1,6 @@ -(module planet-archives mzscheme +#lang scheme/base + (require "private/planet-shared.ss" - mzlib/file "config.ss" "cachepath.ss") @@ -56,5 +56,3 @@ (define (get-all-planet-packages) (append (get-installed-planet-archives) (get-hard-linked-packages))) - - ) diff --git a/collects/planet/planet.ss b/collects/planet/planet.ss index 5942c9aefd..3a986ecd9c 100644 --- a/collects/planet/planet.ss +++ b/collects/planet/planet.ss @@ -1,4 +1,5 @@ -(module planet mzscheme +#lang scheme/base + #| This module contains code that implements the `planet' command-line tool. @@ -6,11 +7,11 @@ PLANNED FEATURES: * Disable a package without removing it (disabling meaning that if it's a tool it won't start w/ DrScheme, etc) |# - (require mzlib/string - mzlib/file - (only mzlib/list sort) - net/url - mzlib/match + (require net/url + scheme/path + scheme/file + scheme/match + (only-in mzlib/string read-from-string) "config.ss" "private/planet-shared.ss" @@ -138,7 +139,7 @@ This command does not unpack or install the named .plt file." (when (file-exists? pkg) (fail "Cannot download, there is a file named ~a in the way" pkg)) (match (download-package full-pkg-spec) - [(#t path maj min) + [(list #t path maj min) (copy-file path pkg) (printf "Downloaded ~a package version ~a.~a\n" pkg maj min)] [_ @@ -192,7 +193,10 @@ This command does not unpack or install the named .plt file." (for-each (lambda (l) (apply printf " ~a\t~a\t~a ~a\n" l)) (sort-by-criteria - (map (lambda (x) (match x [(_ owner pkg _ maj min) (list owner pkg maj min)])) normal-packages) + (map (lambda (x) + (match x [(list _ owner pkg _ maj min) + (list owner pkg maj min)])) + normal-packages) (list string ~a\n" l)) (sort-by-criteria (map - (lambda (x) (match x [(dir owner pkg _ maj min) (list owner pkg maj min (path->string dir))])) + (lambda (x) + (match x + [(list dir owner pkg _ maj min) + (list owner pkg maj min (path->string dir))])) devel-link-packages) (list stringlist #'(name ...))) #'(begin (provide name ...) - (define name (make-parameter val)) ...)]))) + (define name (make-parameter val)) ...)])) diff --git a/collects/planet/private/linkage.ss b/collects/planet/private/linkage.ss index 8acf97ded8..26ed481c6e 100644 --- a/collects/planet/private/linkage.ss +++ b/collects/planet/private/linkage.ss @@ -1,8 +1,8 @@ -(module linkage mzscheme +#lang scheme/base (require "planet-shared.ss" "../config.ss" - mzlib/match) + scheme/match) (provide get/linkage get-linkage @@ -50,16 +50,15 @@ (define (add-linkage! rmp pkg-spec pkg) (when rmp (let ((key (get-key rmp pkg-spec))) - (hash-table-get + (hash-ref (get-linkage-table) key (lambda () (let ((plist (pkg-as-list pkg))) (begin - (hash-table-put! (get-linkage-table) key plist) - (with-output-to-file (LINKAGE-FILE) - (lambda () (write (list key plist))) - 'append))))))) + (hash-set! (get-linkage-table) key plist) + (with-output-to-file (LINKAGE-FILE) #:exists 'append + (lambda () (write (list key plist)))))))))) pkg) ;; remove-linkage! pkg-spec -> void @@ -68,32 +67,29 @@ (let ((l (get-linkage-table))) ;; first remove bad entries from the in-memory hash table - (hash-table-for-each + (hash-for-each l (lambda (k v) (match v - [(name route maj min _) + [(list name route maj min _) (when (and (equal? name (pkg-name pkg)) (equal? route (pkg-route pkg)) (= maj (pkg-maj pkg)) (= min (pkg-min pkg))) - (hash-table-remove! l k))] + (hash-remove! l k))] [_ (void)]))) ;; now write the new table out to disk to keep it in sync - (with-output-to-file (LINKAGE-FILE) + (with-output-to-file (LINKAGE-FILE) #:exists 'truncate/replace (lambda () (printf "\n") - (hash-table-for-each + (hash-for-each l - (lambda (k v) (write (list k v))))) - 'truncate/replace))) + (lambda (k v) (write (list k v)))))))) ;; kill the whole linkage-table (define (remove-all-linkage!) - (with-output-to-file (LINKAGE-FILE) - (lambda () (printf "\n")) - 'truncate/replace) + (with-output-to-file (LINKAGE-FILE) #:exists 'truncate/replace newline) (set! LT #f)) ;; pkg-as-list : PKG -> (list string string nat nat bytes[path]) @@ -111,13 +107,13 @@ (define (get-linkage rmp pkg-specifier) (cond [rmp - (let ((pkg-fields (hash-table-get + (let ((pkg-fields (hash-ref (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]) + (match-let ([(list name route maj min pathbytes) pkg-fields]) (make-pkg name route maj min (bytes->path pathbytes)))) #f))] [else #f])) @@ -136,6 +132,3 @@ ; key suitable for marshalling that represents the given resolved-module-path (define (get-module-id rmp) (path->string (resolved-module-path-name rmp))) - - ) - diff --git a/collects/planet/resolver.ss b/collects/planet/resolver.ss index 2725b9b052..8ac3918dee 100644 --- a/collects/planet/resolver.ss +++ b/collects/planet/resolver.ss @@ -160,7 +160,7 @@ subdirectory. ||# -#lang mzscheme +#lang scheme/base (define resolver (case-lambda @@ -177,23 +177,23 @@ subdirectory. stx load?)])) -(require mzlib/match - mzlib/file - mzlib/port - mzlib/list - - mzlib/date +(require scheme/match + scheme/path + scheme/file + scheme/port + scheme/date + scheme/tcp + mzlib/struct net/url net/head - mzlib/struct "config.ss" "private/planet-shared.ss" "private/linkage.ss" "parsereq.ss") -(provide (rename resolver planet-module-name-resolver) +(provide (rename-out [resolver planet-module-name-resolver]) resolve-planet-path pkg-spec->full-pkg-spec get-package-from-cache @@ -219,13 +219,13 @@ subdirectory. (define (establish-diamond-property-monitor) (unless VER-CACHE-NAME (set! VER-CACHE-NAME (gensym))) (unless (namespace-variable-value VER-CACHE-NAME #t (lambda () #f)) - (namespace-set-variable-value! VER-CACHE-NAME (make-hash-table 'equal)))) + (namespace-set-variable-value! VER-CACHE-NAME (make-hash)))) (define (the-version-cache) (namespace-variable-value VER-CACHE-NAME)) (define (pkg->diamond-key pkg) (cons (pkg-name pkg) (pkg-route pkg))) (define (pkg-matches-bounds? pkg bound-info) - (match-let ([(maj lo hi) bound-info]) + (match-let ([(list maj lo hi) bound-info]) (and (= maj (pkg-maj pkg)) (or (not lo) (>= (pkg-min pkg) lo)) (or (not hi) (<= (pkg-min pkg) hi))))) @@ -235,18 +235,18 @@ subdirectory. (define (build-compatibility-fn compat-data) (define pre-fn (match compat-data - [`none (lambda (_) #f)] - [`all (lambda (_) #t)] - [`(all-except ,vspec ...) + ['none (lambda (_) #f)] + ['all (lambda (_) #t)] + [(list 'all-except vspec ...) (let ([bounders (map (λ (x) (version->bounds x (λ (_) #f))) vspec)]) (if (andmap (lambda (x) x) bounders) (lambda (v) (not (ormap (lambda (bounder) (pkg-matches-bounds? v bounder)) bounders))) #f))] - [`(only ,vspec ...) + [(list 'only vspec ...) (let ([bounders (map (λ (x) (version->bounds x (λ (_) #f))) vspec)]) - (if (andmap (lambda (x) x) bounders) + (when (andmap (lambda (x) x) bounders) (lambda (v) (andmap (lambda (bounder) (pkg-matches-bounds? v bounder)) bounders))) @@ -274,7 +274,7 @@ subdirectory. (define (add-pkg-to-diamond-registry! pkg stx) (let ([loaded-packages - (hash-table-get (the-version-cache) (pkg->diamond-key pkg) '())]) + (hash-ref (the-version-cache) (pkg->diamond-key pkg) '())]) (unless (list? loaded-packages) (error 'PLaneT "Inconsistent state: expected loaded-packages to be a list, received: ~s" loaded-packages)) (let ([all-violations '()]) @@ -306,9 +306,9 @@ subdirectory. (unless (null? all-violations) (let ([worst (or (assq values all-violations) (car all-violations))]) (raise (cadr worst))))) - (hash-table-put! (the-version-cache) - (pkg->diamond-key pkg) - (cons (list pkg stx) loaded-packages)))) + (hash-set! (the-version-cache) + (pkg->diamond-key pkg) + (cons (list pkg stx) loaded-packages)))) ;; ============================================================================= ;; MAIN LOGIC @@ -477,7 +477,7 @@ subdirectory. ;; the uninstalled-packages cache, then returns a promise for it (define (get-package-from-server pkg) (match (download-package pkg) - [(#t tmpfile-path maj min) + [(list #t tmpfile-path maj min) (let* ([upkg (make-uninstalled-pkg tmpfile-path pkg maj min)] [cached-path (save-to-uninstalled-pkg-cache! upkg)] [final (make-uninstalled-pkg cached-path pkg maj min)]) @@ -485,7 +485,7 @@ subdirectory. (normalize-path cached-path)) (delete-file tmpfile-path)) ;; remove the tmp file, we're done with it final)] - [(#f str) + [(list #f str) (string-append "PLaneT could not find the requested package: " str)] [(? string? s) (string-append "PLaneT could not download the requested package: " s)])) @@ -543,7 +543,7 @@ subdirectory. (pkg-spec-name pkg) (current-time)) ;; oh man is this a bad hack! - (parameterize ([current-namespace (make-namespace)]) + (parameterize ([current-namespace (make-base-namespace)]) (let ([ipp (dynamic-require 'setup/plt-single-installer 'install-planet-package)]) (ipp path the-dir (list owner (pkg-spec-name pkg) @@ -582,9 +582,12 @@ subdirectory. (fprintf op "PLaneT/1.0\n") (flush-output op) (match (read ip) - ['ok (state:send-pkg-request)] - [('invalid (? string? msg)) (state:abort (string-append "protocol version error: " msg))] - [bad-msg (state:abort (format "server protocol error (received invalid response): ~a" bad-msg))])) + ['ok + (state:send-pkg-request)] + [(list 'invalid (? string? msg)) + (state:abort (string-append "protocol version error: " msg))] + [bad-msg + (state:abort (format "server protocol error (received invalid response): ~a" bad-msg))])) (define (state:send-pkg-request) (request-pkg-list (list pkg)) @@ -592,16 +595,16 @@ subdirectory. (define (state:receive-package) (match (read ip) - [(_ 'get 'ok (? nat? maj) (? nat? min) (? nat? bytes)) + [(list _ 'get 'ok (? nat? maj) (? nat? min) (? nat? bytes)) (let ([filename (make-temporary-file "planettmp~a.plt")]) (read-char ip) ; throw away newline that must be present (read-n-chars-to-file bytes ip filename) (list #t filename maj min))] - [(_ 'error 'malformed-request (? string? msg)) + [(list _ 'error 'malformed-request (? string? msg)) (state:abort (format "Internal error (malformed request): ~a" msg))] - [(_ 'get 'error 'not-found (? string? msg)) + [(list _ 'get 'error 'not-found (? string? msg)) (state:failure (format "Server had no matching package: ~a" msg))] - [(_ 'get 'error (? symbol? code) (? string? msg)) + [(list _ 'get 'error (? symbol? code) (? string? msg)) (state:abort (format "Unknown error ~a receiving package: ~a" code msg))] [bad-response (state:abort (format "Server returned malformed message: ~e" bad-response))])) @@ -631,8 +634,8 @@ subdirectory. ;; get-http-response-code : header[from net/head] -> string ;; gets the HTTP response code in the given header (define (get-http-response-code header) - (let ([parsed (regexp-match #rx"^HTTP/[^ ]* ([^ ]*)" header)]) - (and parsed (cadr parsed)))) + (cond [(regexp-match #rx"^HTTP/[^ ]* ([^ ]*)" header) => cadr] + [else #f])) ;; pkg->download-url : FULL-PKG-SPEC -> url ;; gets the download url for the given package @@ -679,7 +682,7 @@ subdirectory. [maj (string->number maj/str)] [min (string->number min/str)] [content-length (string->number content-length/str)] - [op (open-output-file filename 'truncate/replace)]) + [op (open-output-file filename #:exists 'truncate/replace)]) (copy-port ip op) (close-input-port ip) (close-output-port op) @@ -728,8 +731,6 @@ subdirectory. ;; UTILITY ;; A few small utility functions -(define (last l) (car (last-pair l))) - ;; make-directory*/paths : path -> (listof path) ;; like make-directory*, but returns what directories it actually created (define (make-directory*/paths dir) diff --git a/collects/planet/util.ss b/collects/planet/util.ss index 92c024bf7d..9d30ff7c69 100644 --- a/collects/planet/util.ss +++ b/collects/planet/util.ss @@ -1,4 +1,4 @@ -#lang scheme +#lang scheme/base (require "config.ss" "planet-archives.ss" @@ -10,7 +10,12 @@ net/url xml/xml + scheme/contract + scheme/path + scheme/file scheme/port + scheme/match + scheme/class setup/pack setup/plt-single-installer @@ -18,7 +23,8 @@ setup/unpack (prefix-in srfi1: srfi/1) - ) + + (for-syntax scheme/base)) #| The util collection provides a number of useful functions for interacting with the PLaneT system. |#