From 7b81dbdd9895b628feecf87085c73c7e2fc9a6fc Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Fri, 4 Oct 2002 14:31:28 +0000
Subject: [PATCH] SERVLET-FORM accepts a method specifier: SERVLET-FORM
 return-address [method] [attributes] [elements]

---
 scheme/httpd/surflets/surflets.scm | 35 +++++++++++++++++++-----------
 1 file changed, 22 insertions(+), 13 deletions(-)

diff --git a/scheme/httpd/surflets/surflets.scm b/scheme/httpd/surflets/surflets.scm
index 117d2f6..e66acd4 100644
--- a/scheme/httpd/surflets/surflets.scm
+++ b/scheme/httpd/surflets/surflets.scm
@@ -136,22 +136,31 @@
        ;; Must do something to prevent the callback-function string to
        ;; be HTML escaped.
        *preorder*
-       . ,(lambda (trigger call-back-function . elems)
-	     (if (and (pair? elems)
-		      (XML-attribute? (car elems)))
-		 (make-servlet-form call-back-function (cdar elems) (cdr elems))
-		 (make-servlet-form call-back-function'() elems)))))
+       . ,(lambda (trigger call-back-function . args)
+	    (receive (parameters elems)
+		(typed-optionals (list symbol? XML-attribute?) args)
+	      (make-servlet-form call-back-function 
+				 (car parameters)
+				 (cadr parameters)
+				 elems)))))
   ))
 
-(define (make-servlet-form call-back-function attributes elems)
-  `("<form" ,@(map (lambda (attribute-value)
-		     ((enattr (car attribute-value)) (cadr attribute-value)))
-		   `((method "POST")
-		     (action ,call-back-function)
-		     ,@attributes))
-    #\> #\newline
+(define (make-servlet-form call-back-function method attributes elems)
+  (let ((real-method (case method
+		       ((get GET) "GET")
+		       ((post POST) "POST")
+		       ((#f) "GET")
+		       (else
+			(error "invalid method type" method)))))
+    `("<form" ,@(map (lambda (attribute-value)
+		       ((enattr (car attribute-value)) (cadr attribute-value)))
+		     `((method ,real-method)
+		       (action ,call-back-function)
+		       ;; We have to divide attributes explicitly.
+		       ,@(if attributes (cdr attributes) '())))
+      #\> #\newline
     ,(reformat elems)
-    "</form>"))
+    "</form>")))
 
 (define (XML-attribute? thing)
   (and (pair? thing)