From fb75cd4efe16b7008d704f3b45c8f1e937a87e9c Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Sat, 9 Nov 2002 17:17:14 +0000
Subject: [PATCH] Add infrastructure for saving default values in get-results.

---
 scheme/httpd/surflets/packages.scm           |  2 +-
 scheme/httpd/surflets/simple-surflet-api.scm | 67 ++++++++++++--------
 2 files changed, 41 insertions(+), 28 deletions(-)

diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm
index 1b87d95..3a4fbc7 100644
--- a/scheme/httpd/surflets/packages.scm
+++ b/scheme/httpd/surflets/packages.scm
@@ -279,7 +279,7 @@
 	define-record-types
 	let-opt
 	servlets
-	(subset srfi-1 (zip filter))
+	(subset srfi-1 (zip filter find make-list))
 	handle-fatal-error
 	)
   (files simple-servlet-api))
diff --git a/scheme/httpd/surflets/simple-surflet-api.scm b/scheme/httpd/surflets/simple-surflet-api.scm
index 60da9fe..22cdf6b 100644
--- a/scheme/httpd/surflets/simple-surflet-api.scm
+++ b/scheme/httpd/surflets/simple-surflet-api.scm
@@ -13,32 +13,41 @@
   (zip (map car assoc-query-list)
        (get-results (map cadr assoc-query-list) "Web Query")))
 
-(define (get-results queries title . maybe-update-text)
-  (let* ((queries (map transform-string-to-query queries))
-	 (update-text (:optional maybe-update-text #f))
-	 (req (send-html/suspend
-	       (lambda (new-url)
-		 `(html 
-		   (title ,title)
-		   (body (@ (bgcolor "white"))
-			 (h3 ,(if update-text `(font (@ (color "red")) ,update-text) title))
-			 (servlet-form ,new-url POST
-				       (table ,@(map (lambda (query)
-						       (ask query 'html-table-row))
-						     queries))
-				       ,(make-submit-button)))))))
-	 (bindings (get-bindings req)))
-    (call-with-current-continuation
-     (lambda (exit)
-       (map (lambda (query)
-	      (with-fatal-error-handler
-	       (lambda (c m)
-		 (exit
-		  (get-results queries title
-			       (ask query 'bad-input-text))))
-	       (ask query 'value bindings)))
-       queries)))))
+(define (get-results queries title . maybe-update-text+defaults)
+  (let-optionals maybe-update-text+defaults
+      ((update-text #f)
+       (defaults (make-list (length queries) #f)))
+    (let* ((queries (map transform-string-to-query queries))
+	   (req (send-html/suspend
+		 (lambda (new-url)
+		   (generate-simple-servlet-page new-url update-text
+						 title
+						 queries defaults))))
+	   (bindings (get-bindings req))
+	   (queries+values (map (lambda (query)
+				  (cons query (ask query 'value bindings)))
+				queries))
+	   (bad-query+value (find (lambda (query+value) 
+				    (not (cdr query+value)))
+				  queries+values)))
+      (if bad-query+value
+	  (get-results queries title
+		       (ask (car bad-query+value) 'bad-input-text)
+		       (map cdr queries+values))
+	  (map cdr queries+values)))))
 
+(define (generate-simple-servlet-page new-url update-text title queries defaults)
+  `(html 
+    (title ,title)
+    (body (@ (bgcolor "white"))
+	  (h3 ,(if update-text 
+		   `(font (@ (color "red")) ,update-text) 
+		   title))
+	  (servlet-form ,new-url POST
+			(table ,@(map (lambda (query default)
+					(ask query 'html-table-row default))
+				      queries defaults))
+			,(make-submit-button)))))
 
 ;; Post some information on a Web page, wait for continue signal.
 (define (inform title . text)
@@ -77,7 +86,10 @@
   (lambda (message)
     (case message
       ((html-table-row)
-       (lambda (self)
+       (lambda (self default)
+	 ;; DEFAULT is ignored currently. There is a problem with
+	 ;; adding the default-value to an already generated
+	 ;; input-field.
 	 `(tr (td ,text) (td ,input-field))))
       ((value)
        (lambda (self bindings)
@@ -115,7 +127,8 @@
     (lambda (message)
       (case message
 	((html-table-row)
-	 (lambda (self)
+	 (lambda (self default)
+	   ;; See note above for default.
 	   `(tr (td ,text)
 		(td (table (tr
 			    ,@(map (lambda (radio choice)