From b45ea7717b0d1e4ee70b011f6a2a3a9ac85f9626 Mon Sep 17 00:00:00 2001
From: Jacob Matthews <jacobm@cs.uchicago.edu>
Date: Tue, 28 Nov 2006 05:48:34 +0000
Subject: [PATCH] Added a command-line flag analagous to -l but for planet
 packages (which have to already be installed)

svn: r4966
---
 collects/setup/setup-cmdline.ss | 10 +++++++++-
 collects/setup/setup-go.ss      |  4 ++--
 collects/setup/setup-unit.ss    | 23 +++++++++++++++++++----
 collects/setup/setup.ss         |  2 +-
 4 files changed, 31 insertions(+), 8 deletions(-)

diff --git a/collects/setup/setup-cmdline.ss b/collects/setup/setup-cmdline.ss
index 37d0a99439..129d759682 100644
--- a/collects/setup/setup-cmdline.ss
+++ b/collects/setup/setup-cmdline.ss
@@ -16,6 +16,8 @@
   ;;  - A list of archives
 
   (define (parse-cmdline argv)
+    
+    (define x-specific-planet-packages '())
     (define x-flags null)
     (define (add-flags l)
       (set! x-flags (append (reverse l) x-flags)))
@@ -24,6 +26,12 @@
       (command-line
        "setup-plt"
        argv
+       (multi
+        [("-P") owner package-name maj min
+         "Setup specified PLaneT packages only"
+         (set! 
+          x-specific-planet-packages
+          (cons (list owner package-name maj min) x-specific-planet-packages))])
        (once-each
 	[("-c" "--clean") "Delete existing compiled files; implies -nxi"
 	 (add-flags '((clean #t)
@@ -74,4 +82,4 @@
 	  (printf "If no <archive> or -l <collection> is specified, all collections are setup~n")
 	  (exit 0)))))
 
-    (values x-flags x-specific-collections x-archives)))
+    (values x-flags x-specific-collections x-specific-planet-packages x-archives)))
diff --git a/collects/setup/setup-go.ss b/collects/setup/setup-go.ss
index 23fb0393a8..06eec53b79 100644
--- a/collects/setup/setup-go.ss
+++ b/collects/setup/setup-go.ss
@@ -11,7 +11,7 @@
   (define-values/invoke-unit/sig setup-option^
     setup:option@)
 
-  (define-values (x-flags x-specific-collections x-archives)
+  (define-values (x-flags x-specific-collections x-specific-planet-packages x-archives)
     (parse-cmdline (current-command-line-arguments)))
 
   ;; Pseudo-option:
@@ -46,7 +46,7 @@
 
   (specific-collections x-specific-collections)
   (archives x-archives)
-  (specific-planet-dirs '())
+  (specific-planet-dirs x-specific-planet-packages)
 
   (require (lib "launcher-sig.ss" "launcher")
 	   (lib "launcher-unit.ss" "launcher")
diff --git a/collects/setup/setup-unit.ss b/collects/setup/setup-unit.ss
index 6c9ef10650..7ec1aaff10 100644
--- a/collects/setup/setup-unit.ss
+++ b/collects/setup/setup-unit.ss
@@ -11,6 +11,7 @@
 	   (lib "port.ss")
            (lib "match.ss")
            (lib "planet-archives.ss" "planet")
+           (lib "planet-shared.ss" "planet" "private")
            
 	   "option-sig.ss"
 	   (lib "sig.ss" "compiler")
@@ -144,6 +145,19 @@
       ;; returns the non-false elements of l in order
       (define (remove-falses l) (filter (lambda (x) x) l))
       
+      ;; planet-spec->planet-list : (list string string nat nat) -> (list path string string (listof string) nat nat) | #f
+      ;; converts a planet package spec into the information needed to create a cc structure
+      (define (planet-spec->planet-list spec)
+        (let-values ([(owner pkg-name maj-str min-str) (apply values spec)])
+          (let ([maj (string->number maj-str)]
+                [min (string->number min-str)])
+            (unless maj (error 'setup-plt "Bad major version for PLaneT package: ~s" maj-str))
+            (unless min (error 'setup-plt "Bad minor version for PLaneT package: ~s" min-str))
+            (let ([pkg (lookup-package-by-keys owner pkg-name maj min min)])
+              (if pkg
+                  pkg
+                  (error 'setup-plt "Not an installed PLaneT package: (~s ~s ~s ~s)" owner pkg-name maj min))))))
+      
       (define (planet->cc path owner pkg-file extra-path maj min)
         (unless (path? path)
             (error 'path->cc "non-path when building package ~a" pkg-file))
@@ -155,9 +169,10 @@
                                     (when x
                                       (unless (string? x)
                                         (error 
-                                         (format 
-                                          "'name' result from directory ~s is not a string:"
-                                          path)
+                                         (string->immutable-string
+                                          (format 
+                                           "'name' result from directory ~s is not a string:"
+                                           path))
                                          x)))))])
             (make-cc
              #f
@@ -192,7 +207,7 @@
          (map (lambda (spec) (apply planet->cc spec))
               (if (and (null? x-specific-collections) (null? x-specific-planet-dirs))
                   (get-all-planet-packages)
-                  x-specific-planet-dirs))))
+                  (remove-falses (map planet-spec->planet-list x-specific-planet-dirs))))))
       
       (define collections-to-compile
 	(sort
diff --git a/collects/setup/setup.ss b/collects/setup/setup.ss
index f5c8c6a2fa..a9f5f95574 100644
--- a/collects/setup/setup.ss
+++ b/collects/setup/setup.ss
@@ -13,7 +13,7 @@
   (when (file-stream-port? (current-output-port))
     (file-stream-buffer-mode (current-output-port) 'line))
 
-  (define-values (flags specific-collections archives)
+  (define-values (flags specific-collections specific-planet-packages archives)
     ;; Load the command-line parser without using .zos, 
     ;;  and in its own namespace to avoid poluuting the cm-managed
     ;;  namespace later