Finish move to v4

svn: r10758

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))

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))
-    

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)))
-  
-  )

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
+  (require net/url
-           mzlib/file
+           scheme/path
-           (only mzlib/list sort)
+           scheme/file
-           net/url
+           scheme/match
-           mzlib/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<? string=?)
           (list string<? string=?)
           (list < =)
@@ -204,7 +208,10 @@ This command does not unpack or install the named .plt file."
          (lambda (l) (apply printf "  ~a\t~a\t~a ~a\n    --> ~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 string<? string=?)
           (list string<? string=?)
@@ -287,4 +294,4 @@ This command does not unpack or install the named .plt file."
                    (lambda (e) 
                      (fprintf (current-error-port) "~a\n" (exn-message e))
                      (exit 1))])
-    (start)))
+    (start))

collects/planet/private/define-config.ss

@@ -1,4 +1,5 @@
-(module define-config scheme/base
+#lang scheme/base
+
   (require (for-syntax scheme/base))
 
   (provide define-parameters)
@@ -9,4 +10,4 @@
        (andmap identifier? (syntax->list #'(name ...)))
        #'(begin
            (provide name ...)
-           (define name (make-parameter val)) ...)])))
+           (define name (make-parameter val)) ...)]))

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)
+               (hash-set! (get-linkage-table) key plist)
-               (with-output-to-file (LINKAGE-FILE)
+               (with-output-to-file (LINKAGE-FILE) #:exists 'append
-                 (lambda () (write (list key plist)))
+                 (lambda () (write (list key plist))))))))))
-                 'append)))))))
     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)))))
+           (lambda (k v) (write (list k v))))))))
-        'truncate/replace)))
   
   ;; kill the whole linkage-table
   (define (remove-all-linkage!)
-    (with-output-to-file (LINKAGE-FILE)
+    (with-output-to-file (LINKAGE-FILE) #:exists 'truncate/replace newline)
-      (lambda () (printf "\n"))
-      'truncate/replace)
     (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)))
-  
-  )
-

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
+(require scheme/match
-         mzlib/file
+         scheme/path
-         mzlib/port
+         scheme/file
-         mzlib/list
+         scheme/port
-
+         scheme/date
-         mzlib/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)]
+      ['none (lambda (_) #f)]
-      [`all (lambda (_) #t)]
+      ['all (lambda (_) #t)]
-      [`(all-except ,vspec ...)
+      [(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,7 +306,7 @@ subdirectory.
       (unless (null? all-violations)
         (let ([worst (or (assq values all-violations) (car all-violations))])
           (raise (cadr worst)))))
-    (hash-table-put! (the-version-cache)
+    (hash-set! (the-version-cache)
                (pkg->diamond-key pkg)
                (cons (list pkg stx) loaded-packages))))
 
@@ -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)]
+      ['ok
-      [('invalid (? string? msg)) (state:abort (string-append "protocol version error: " msg))]
+       (state:send-pkg-request)]
-      [bad-msg                    (state:abort (format "server protocol error (received invalid response): ~a" bad-msg))]))
+      [(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)])
+  (cond [(regexp-match #rx"^HTTP/[^ ]* ([^ ]*)" header) => cadr]
-    (and parsed (cadr parsed))))
+        [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)

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. |#