~ chicken-core (chicken-5) e891c3e9238c3cf144266314f600e1d26bbd562d

commit e891c3e9238c3cf144266314f600e1d26bbd562d
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jun 25 12:30:00 2010 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Fri Jun 25 12:30:00 2010 +0200

    added 'mode' query-option to henrietta and setup-download

diff --git a/scripts/henrietta.scm b/scripts/henrietta.scm
index 7747056b..af227e22 100644
--- a/scripts/henrietta.scm
+++ b/scripts/henrietta.scm
@@ -49,6 +49,7 @@
   (define *username* #f)
   (define *password* #f)
   (define *tests* #f)
+  (define *mode* 'default)
 
   (define (headers)
     (print "Connection: close\r\nContent-type: text/plain\r\n\r\n"))
@@ -77,6 +78,7 @@
 		  quiet: #t 
 		  destination: #f
 		  tests: *tests*
+		  mode: *mode*
 		  username: *username* 
 		  password: *password*))))
       (unless dir 
@@ -92,7 +94,8 @@
 			(print "\n#|-------------------- " version " |# \"" pf "/\" 0")
 			(walk ff pf))
 		       (else
-			(print "\n#|-------------------- " version " |# \"" pf "\" " (file-size ff))
+			(print "\n#|-------------------- " version " |# \"" pf "\" " 
+			       (file-size ff))
 			(display (read-all ff)))))))
 	   files)))
       (print "\n#!eof") ) )
@@ -145,6 +148,9 @@
 		  ((string=? ms "list")
 		   (headers)
 		   (listing))
+		  ((string=? ms "mode")
+		   (set! *mode* (string->symbol (apply substring qs (caddr m))))
+		   (loop rest))
 		  (else
 		   (warning "unrecognized query option" ms)
 		   (loop rest))))))))
diff --git a/setup-download.scm b/setup-download.scm
index 51727dd1..02a687ad 100644
--- a/setup-download.scm
+++ b/setup-download.scm
@@ -49,6 +49,7 @@
   (define *quiet* #f)
   (define *chicken-install-user-agent* (conc "chicken-install " (chicken-version)))
   (define *trunk* #f)
+  (define *mode* 'default)
 
   (define (d fstr . args)
     (let ([port (if *quiet* (current-error-port) (current-output-port))])
@@ -105,7 +106,9 @@
 			   (cons (list 'version version)
 				 (handle-exceptions ex
 				     (begin
-				       (warning "extension has syntactically invalid .meta file" egg)
+				       (warning 
+					"extension has syntactically invalid .meta file" 
+					egg)
 				       (return #f))
 				   (with-input-from-file meta read))))))))))
        ls)))
@@ -126,7 +129,7 @@
          (map (lambda (s) (string-append (string-chomp s "/") "\n"))
               (with-input-from-pipe cmd read-lines))) ) ) )
 
-  (define (locate-egg/svn egg repo #!optional version destination username  password)
+  (define (locate-egg/svn egg repo #!optional version destination username password)
     (let* ([uarg (if username (string-append "--username='" username "'") "")]
 	   [parg (if password (string-append "--password='" password "'") "")]
 	   [cmd (make-svn-ls-cmd uarg parg (make-pathname repo egg) recursive?: #t)])
@@ -145,13 +148,27 @@
                             (if (member "trunk/" files)
                                 (values "trunk" "trunk")
                                 (values "" "") ) ) ) ] )
-          (let* ([tmpdir (make-pathname (or destination (get-temporary-directory)) egg)]
-                 [cmd (make-svn-export-cmd uarg parg (conc repo #\/ egg #\/ filedir) tmpdir)])
+          (let* ((tmpdir (make-pathname (or destination (get-temporary-directory)) egg))
+                 (cmd (make-svn-export-cmd 
+		       uarg parg
+		       (conc 
+			repo #\/ egg #\/
+			(if (eq? *mode* 'meta)
+			    (metafile filedir egg)
+			    filedir))
+		       (if (eq? *mode* 'meta)
+			   (begin
+			     (create-directory tmpdir)
+			     (metafile tmpdir egg))
+			   tmpdir))))
 	    (d "  ~a~%" cmd)
 	    (if (zero? (system cmd))
                 (values tmpdir ver)
 	        (values #f "") ) ) ) ) ) )
 
+  (define (metafile dir egg)
+    (conc dir #\/ egg ".meta"))
+
   (define (deconstruct-url url)
     (let ([m (string-match "(http://)?([^/:]+)(:([^:/]+))?(/.+)" url)])
       (values
@@ -170,6 +187,7 @@
 		     locn
 		     "?name=" egg
 		     (if version (string-append "&version=" version) "")
+		     "&mode=" (->string *mode*)
 		     (if tests "&tests=yes" ""))]
 	      [eggdir (make-pathname tmpdir egg) ] )
 	  (unless (file-exists? eggdir) (create-directory eggdir))
@@ -291,19 +309,20 @@
 
   (define (retrieve-extension name transport location
                               #!key version quiet destination username password tests
-			      proxy-host proxy-port trunk)
+			      proxy-host proxy-port trunk (mode 'default))
     (fluid-let ((*quiet* quiet)
-		(*trunk* trunk))
+		(*trunk* trunk)
+		(*mode* mode))
       (case transport
-	[(local)
+	((local)
 	 (when destination (warning "destination for transport `local' ignored"))
-	 (locate-egg/local name location version destination) ]
-	[(svn)
-	 (locate-egg/svn name location version destination username password) ]
-	[(http)
-	 (locate-egg/http name location version destination tests proxy-host proxy-port) ]
-	[else
-	 (error "cannot retrieve extension unsupported transport" transport) ] ) ) )
+	 (locate-egg/local name location version destination) )
+	((svn)
+	 (locate-egg/svn name location version destination username password) )
+	((http)
+	 (locate-egg/http name location version destination tests proxy-host proxy-port) )
+	(else
+	 (error "cannot retrieve extension unsupported transport" transport) ) ) ) )
 
   (define (list-extensions transport location #!key quiet username password)
     (fluid-let ((*quiet* quiet))