From a9f5c6ffa7c21a10e86a6897dfa48e2768f5762e Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Wed, 16 Apr 2003 12:32:24 +0000
Subject: [PATCH] test.scm now shows examples for all surflets-input-fields.

---
 .../surflets/web-server/root/img/221.gif      | Bin 0 -> 274 bytes
 .../web-server/root/surflets/test.scm         | 235 +++++++++++++-----
 2 files changed, 168 insertions(+), 67 deletions(-)
 create mode 100644 scheme/httpd/surflets/web-server/root/img/221.gif

diff --git a/scheme/httpd/surflets/web-server/root/img/221.gif b/scheme/httpd/surflets/web-server/root/img/221.gif
new file mode 100644
index 0000000000000000000000000000000000000000..a183e4f0480cd8e75bc32316a63263d921e415df
GIT binary patch
literal 274
zcmZ?wbhEHb<Yf?K_`t{j1poj4SNx}>px~KXkY7}inxc?al%J~*;ODE5nVXoNYNcRg
zWT;n=l*^#_lLe@OkwFKf3#8wH>9CKGAP_ilD6#;>6j}sW9AOBk6v_rMI9Qk(9TXTK
w6oSXl;Gh8F0X0Jf(I^2J04hKN3<Ah}kQAH`avW4GoB@(Y(v8dvU|_HY0Bxlt%K!iX

literal 0
HcmV?d00001

diff --git a/scheme/httpd/surflets/web-server/root/surflets/test.scm b/scheme/httpd/surflets/web-server/root/surflets/test.scm
index 10248a7..fdf5f55 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/test.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/test.scm
@@ -1,87 +1,188 @@
 (define-structure surflet surflet-interface
   (open scheme-with-scsh
 	surflets
+	receiving
+	srfi-1
+	srfi-13
+	srfi-14
 	surflets/utilities
 	surflets/callbacks
 	httpd-responses)
   (begin
-    (define global '())
+    (define global 0)
 
-    (define select (make-select-input-field '("a" "b" "c") #t '(@ (size 2))))
+    (define selections (cons  '("a" "b" "c")
+			      '("Andreas" "Bernd" "Clara")))
+    (define radio-elements '(1 2 3 "a" *))
+    (define select (make-annotated-select-input-field 
+		    (map make-annotated-sel-if-option
+			 (car selections)
+			 (cdr selections))
+		    #t '(@ (size 2))))
+    (define select2 (make-select-input-field (car selections)))
+    (define text (make-text-input-field "yoho"))
+    (define number (make-number-input-field 23))
+    (define hidden (make-hidden-input-field "value"))
+    (define password (make-password-input-field "asdf"))
+    (define textarea (make-textarea-input-field "This
+is 
+a
+test"))
+    (define radio (make-annotated-radio-input-field-group))
+    (define radios (map radio radio-elements))
+    (define checkbox (make-annotated-checkbox-input-field "hooray!"))
 
-    (define (result req arg)
-      (send-html
-       `(html (title "Result")
-	      (body (h2 "Result")
-		    (p "Returned via callback with arg" (br)
-		       ,(format #f "~s" arg))))))
-    
+    (define (translate-line-breaks text)
+      (let lp ((result '())
+	       (text text))
+	(let ((index (string-index text char-set:iso-control)))
+	  (if index
+	      (lp (cons '(br)
+			(cons (substring/shared text 0 index) result))
+		  ;; +2, as we probably have cr+lf
+		  (substring/shared text (+ index 2)))
+	      (reverse (cons text result))))))
+
+    (define (cb-result req arg)
+	(send-html
+	 `(html (title "Result")
+		(body (h2 "Result")
+		      (p "Returned via callback with arg" (br)
+			 ,(format #f "~s" arg))
+		      (hr)
+		      (p (url "test.scm" "Test again.") (br)
+			 (url "/" "Return to main menu."))))))
+
+    (define an-cb (make-annotated-callback cb-result))
+    (define addr (make-annotated-address))
     (define (main req)
-      (set! global (cons 1 global))
-      (let* ((an-cb (make-annotated-callback result))
-	     (addr (make-annotated-address))
-	     (req (send-html/suspend
-		  (lambda (new-url)
-		    `(html (body (h1 "This is from SUrflet")
-				 (p "called " ,(length global) " times")
-				 (p "Choose an annotated address:" (br)
-				    (ul
-				     (li (url ,(addr new-url "ab=ba") "ab=ba"))
-				     (li (url ,(addr new-url "be<ta") "be<ta"))
-				     (li  (url ,(addr new-url) "<nothing>"))))
-				 (p "Or choose an annotated callback" (br)
-				    (ul
-				     (li (url ,(an-cb 13) "13"))
-				     (li (url ,(an-cb '(1 2 3)) "'(1 2 3)"))
-				     (li (url ,(an-cb "hello") "hello"))
-				     (li (url ,(an-cb #f) "#f"))))
-				 (surflet-form
-				  ,new-url
-				  POST
-				  ,select
-				  '(input (@ (type "text") (name "TeST")))
-				  ,(make-submit-button))
-				 (hr)
-				 (p (url "/" "Return to main menu."))
-				 )))))
-	     (save-k #f)
-	     (done? #f)
+      (set! global (+ 1 global))
+      (let* ((req (send-html/suspend
+		   (lambda (new-url)
+		     `(html 
+		       (body 
+			(h1 "This is from SUrflet")
+			(p "called " ,global " times")
+			(p "Choose an annotated address:" (br)
+			   (ul
+			    (li (url ,(addr new-url "Eva Gottwald") "ab=ba"))
+			    (li (url ,(addr new-url "be<ta") "be<ta"))
+			    (li  (url ,(addr new-url) "<nothing>"))))
+			(p "Or choose an annotated callback" (br)
+			   (ul
+			    (li (url ,(an-cb 13) "13"))
+			    (li (url ,(an-cb '(1 2 3)) "'(1 2 3)"))
+			    (li (url ,(an-cb "hello") "hello"))
+			    (li (url ,(an-cb #f) "#f"))))
+			(p "Or choose an input field." (br)
+			   (surflet-form
+			    ,new-url
+			    POST
+			    (table
+			     (tr (td "Selection:") (td ,select))
+			     (tr (td "Selection2:") (td ,select2))
+			     (tr (td "Simple text: ") (td ,text))
+			     (tr (td "Number: " ) (td ,number))
+			     (tr (td "Hidden: " ) (td ,hidden))
+			     (tr (td "Password: " ) (td ,password))
+			     (tr (td "Textarea: " ) (td ,textarea))
+			     (tr (td "Radio:")
+				 (td ,(zip radios 
+					   (map (lambda (elem)
+						  (list (format #f "~%~s" elem)
+							'(nbsp) '(nbsp)))
+						radio-elements))))
+			     (tr (td "Checkbox:") (td ,checkbox)))
+			    ,(make-submit-button) ,(make-reset-button) (br)
+			    ,(make-image-button "/img/221.gif")))
+			(hr)
+			(p (url "/" "Return to main menu.")))))))
 	     (bindings (get-bindings req))
+	     (selected (input-field-value select bindings))
+	     (selected2 (input-field-value select2 bindings))
+	     (text-entered (input-field-value text bindings))
+	     (number-entered (input-field-value number bindings))
+	     (hidden-value (input-field-value hidden bindings))
+	     (password-text (input-field-value password bindings))
+	     (textarea-text (input-field-value textarea bindings))
+	     (radio-result (input-field-value (radio #f) bindings))
+	     (checkbox-result (input-field-value checkbox bindings))
 	     (result
 	      (cond
 	       ((returned-via? addr bindings) =>
 		(lambda (string)
 		  (format #f "returned via annotated string ~s" string)))
 	       (else
-		(format #f "~s" bindings)))))
-	
-	(call-with-current-continuation
-	 (lambda (k)
-	   (set! save-k k)
-	   13))
-	
-	(set! global (cons 1 global))
-	(if (not done?)
-	    (begin
-	      (send-html/suspend
-	       (lambda (continue)
-		 `(html (body (h1 "Result")
-			      (p "called " ,(length global) " times")
-			      ,result (br)
-			      (url ,continue "show results again")
-			      (hr)
-			      (p (url "test.scm" "Test again.") (br)
-				 (url "/" "Return to main menu."))))))
-	
-	      (set! done? #t)
-	      (save-k 13))
+		(set-text-input-field-value! text text-entered)
+		(only-select-selected! select selected (cdr selections))
+		(only-select-selected! select2 (list selected2) (car selections))
+		(if number-entered
+		    (set-number-input-field-value! number number-entered))
+		(set-hidden-input-field-value! 
+		 hidden 
+		 (string-append "value" (number->string global)))
+		(set-password-input-field-value! password password-text)
+		(set-textarea-input-field-value! textarea textarea-text)
+		(if radio-result
+		    (begin
+		      (map uncheck-radio-input-field! radios)
+		      (check-radio-input-field! 
+		       (list-ref radios
+				 (list-index (lambda (a) (equal? a radio-result))
+					     radio-elements)))))
+		(if checkbox-result
+		    (check-checkbox-input-field! checkbox)
+		    (uncheck-checkbox-input-field! checkbox))
+		`(p "Returned via submit" (br)
+		    "Bindings were: " ,(format #f "~s" bindings) (br)
+		    (table 
+		     (@ (valign "top"))
+		     (tr (td "Selected: ") (td ,(format #f "~s" selected)))
+		     (tr (td "Selected2:") (td ,(format #f "~s" selected2)))
+		     (tr (td "Text entered:") (td ,(format #f "~s" text-entered)))
+		     (tr (td "Number entered:") 
+			 (td ,(if number-entered
+				  number-entered
+				  "no valid number")))
+		     (tr (td "Hidden:") (td ,hidden-value))
+		     (tr (td "Plain password:") (td ,password-text ))
+		     (tr (td "Textarea:") 
+			 (td #\" ,@(translate-line-breaks textarea-text) #\"))
+		     (tr (td "Radio:") (td ,(format #f "~s" radio-result)))
+		     (tr (td "Checkbox:") (td ,(format #f "~s" checkbox-result)))))
+		    ))))
 
-	    (send-html/finish
-	     `(html (body (h1 "Result 2")
-			  (p "called " ,(length global) " times")
-			  ,(format #f "~s" (get-bindings req))
-			  (hr)
-			  (p (url "test.scm" "Test again.") (br)
-			     (url "/" "Return to main menu."))))))))
+	(set! global (+ 1 global))
+	(send-html/suspend
+	 (lambda (continue)
+	   `(html (body (h1 "Result")
+			(p "called " ,global " times")
+			,result (br)
+			(url ,continue "show results again") (br)
+			(url ,(make-callback main) "continue testing")
+			(font (@ (size "small")) 
+			      "(Note: This is not a browser history link)")
+			(hr)
+			(p (url "test.scm" "Test again.") (br)
+			   (url "/" "Return to main menu."))))))
+	
+	(send-html/finish
+	 `(html (body (h1 "Result 2")
+		      (p "called " ,global " times")
+		      ,(format #f "~s" (get-bindings req))
+		      (hr)
+		      (p (url "test.scm" "Test again.") (br)
+			 (url "/" "Return to main menu.")))))))
+
+    (define (only-select-selected! sel-if selected indices)
+      (for-each (lambda (index)
+		  (unselect-sel-if-option! index sel-if))
+		(iota (length (cdr selections))))
+      (for-each (lambda (selected)
+		  (select-sel-if-option! 
+		   (list-index (lambda (s) (string=? s selected))
+			       indices)
+		   sel-if))
+		selected))
 
     ))