Added package download support to the planet cmdline tool, also fixed a few error string bugs.

svn: r584

collects/planet/planet.ss

@@ -50,6 +50,11 @@ PLANNED FEATURES:
        "  (require (planet \"file.ss\" (<owner> <pkg> <maj> <min>)))"
        "would install"
        (set! actions (cons (lambda () (download/install owner pkg maj min)) actions)))
+      (("-d" "--download")
+       owner pkg maj min
+       ""
+       "Download the given package file without installing it"
+       (set! actions (cons (lambda () (download/no-install owner pkg maj min)) actions)))
       (("-r" "--remove")
        owner pkg maj min
        ""
@@ -67,7 +72,6 @@ PLANNED FEATURES:
        ""
        "List the current linkage table"
        (set! actions (cons show-linkage actions)))
-      
       ;; unimplemented so far:
       #;(("-u" "--unlink")
          module
@@ -79,7 +83,8 @@ PLANNED FEATURES:
   ;; ============================================================
   ;; FEATURE IMPLEMENTATIONS
   
-  (define (fail s) (raise (make-exn:fail s (current-continuation-marks))))
+  (define (fail s . args) 
+    (raise (make-exn:fail (string->immutable-string (apply format s args)) (current-continuation-marks))))
   
   (define (download/install owner pkg majstr minstr)
     (let* ([maj (read-from-string majstr)]
@@ -90,12 +95,26 @@ PLANNED FEATURES:
       (unless (get-package-from-server full-pkg-spec)
         (fail "Could not find matching package"))))
   
+  (define (download/no-install owner pkg majstr minstr)
+    (let* ([maj (read-from-string majstr)]
+           [min (read-from-string minstr)]
+           [full-pkg-spec (pkg-spec->full-pkg-spec (list owner pkg maj min) #f)])
+      (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) 
+         (copy-file path pkg)
+         (printf "Downloaded ~a package version ~a.~a\n" pkg maj min)]
+	[_ 
+        (fail "Could not find matching package")])))
+  
+  
   (define (install-plt-file filestr owner majstr minstr)
     (let ((maj (string->number majstr))
           (min (string->number minstr)))
       (unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0))
         (fail "Invalid major/minor version"))
-      (unless (file-exists? filestr) (fail (format "File does not exist: ~a" filestr)))
+      (unless (file-exists? filestr) (fail "File does not exist: ~a" filestr))
       (let* ([file (normalize-path filestr)]
              [name (let-values ([(base name dir?) (split-path file)]) (path->string name))]
              [spec (list owner name maj min)]
@@ -105,7 +124,7 @@ PLANNED FEATURES:
   
   (define (do-archive p)
     (unless (directory-exists? p)
-      (fail (format "No such directory: ~a" p)))
+      (fail "No such directory: ~a" p))
     (make-planet-archive (normalize-path p)))
   
   (define (remove owner pkg majstr minstr)

collects/planet/resolver.ss

@@ -160,6 +160,7 @@ an appropriate subdirectory.
            pkg-spec->full-pkg-spec
            get-package-from-cache
            get-package-from-server
+           download-package
            install-pkg
            get-planet-module-path/pkg)
 
@@ -287,11 +288,15 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
                                 "Error downloading module from PLaneT server: ~a"
                                 (exn-message e)))
                               (exn-continuation-marks e))))])
-      (let ((download (if (USE-HTTP-DOWNLOADS?) download-package/http download-package)))
+      (match (download-package pkg)
-        (match (download pkg)
+        [(#t path maj min) (install-pkg pkg path maj min)]
-          [(#t path maj min) (install-pkg pkg path maj min)]
+        [(#f str) #f])))
-          [(#f str) #f]))))
   
+  (define (download-package pkg) 
+    ((if (USE-HTTP-DOWNLOADS?) 
+         download-package/http
+         download-package/planet)
+     pkg))
   
   (define (current-time) 
     (let ((date (seconds->date (current-seconds))))
@@ -336,7 +341,7 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
   ; the path is to a file that contains the package. If bool is #f, the package
   ; didn't exist and the string is the server's informative message.
   ; raises an exception if some protocol failure occurs in the download process
-  (define (download-package pkg)
+  (define (download-package/planet pkg)
   
     (define-values (ip op) (tcp-connect (PLANET-SERVER-NAME) (PLANET-SERVER-PORT)))