unify dispatcher: RETURNED-VIA? accepts now input-fields as well as return-addresses.

scheme/httpd/surflets/surflets.scm

@@ -280,9 +280,11 @@
 ;;; input-fields
 ;;; defines input-fields for surflets
 
+;; get-bindings: Transformer will get all bindings of request, not
+;; only the one concerning the input-field.
 (define-record-type input-field :input-field
   (real-make-input-field name transformer HTML-tree get-bindings?)
-  input-field?
+  real-input-field?
   (name input-field-name)
   (transformer input-field-transformer)
   (attributes input-field-attributes)
@@ -294,6 +296,14 @@
     (list 'input-field
 	  (input-field-name input-field))))
 
+;; Have to do a trick to get around with SSAX: input-field is a list
+;; whose first element is 'input-field and the last (next) one is a
+;; real input-field.
+(define (input-field? input-field)
+  (and (pair? input-field)
+       (eq? 'input-field (car input-field))
+       (real-input-field? (cadr input-field))))
+
 ;; FIXME: consider creating small names
 (define generate-unique-name
   (let ((id 0))
@@ -304,6 +314,7 @@
 
 (define identity (lambda (a) a))
 
+;; See note at input-field? for reasons for the list.
 (define (make-input-field name transformer HTML-tree)
   (list 'input-field (real-make-input-field name transformer HTML-tree #f)))
 
@@ -363,7 +374,8 @@
       `(,%receive (params rest-args)
 	   (,%typed-optionals (,%list ,@(map cadr var-list)) ,args)
          (,%if (pair? rest-args)
-	       (,%error "optionals: too many arguments and/or argument type mismatch")
+	       (,%error "optionals: too many arguments and/or argument type mismatch"
+			rest-args)
 	       (,%let (,@(let loop ((counter 0)
 				    (var-list var-list))
 			   (if (null? var-list)
@@ -519,7 +531,9 @@
 	 (attributes XML-attribute?))
       (make-input-field
        name
-       identity
+       (lambda (value)
+	 (or (string=? value "on")
+	     value))
        `(input (@ ((type "checkbox")
 		   (name ,name)
 		   ,(if value `(value ,value) '())
@@ -628,6 +642,10 @@
 	(error "unknown message" message name))))))
 	
 
-(define (returned-via? return-address bindings)
+(define (returned-via? return-object bindings)
-  (assoc (return-address 'name) bindings))
+  (format #t "returned-via? ~a~%" return-object)
+  (if (input-field? return-object)
+      (input-field-binding return-object bindings)
+      ;; We assume we have a return-address-object instead.
+      (assoc (return-object 'name) bindings)))
 

scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm

@@ -53,7 +53,7 @@
 	(cond 
 	 ((returned-via? return-address bindings)
 	  (return-to-main-page req))
-	 ((input-field-binding submit-timeout bindings)
+	 ((returned-via? submit-timeout bindings)
 	   (let ((result (input-field-value number-field bindings)))
 	     (if result
 		 (if (and (integer? result)
@@ -65,7 +65,7 @@
 						(options-session-lifetime))))
 		     (error "not a positive integer"))
 		 (handler-options req "Please enter a valid, positive integer number"))))
-	 ((input-field-binding submit-cache bindings)
+	 ((returned-via? submit-cache bindings)
 	  (let ((cache-plugins? (if (input-field-binding cache-checkbox bindings)
 				    #t 
 				    #f)))

scheme/httpd/surflets/web-server/root/surflets/calculate.scm

@@ -71,7 +71,7 @@
 	(let ((number1 (input-field-value number-field1 bindings))
 	      (number2 (input-field-value number-field2 bindings)))
 	  (cond
-	   ((input-field-binding calculate-button bindings)
+	   ((returned-via? calculate-button bindings)
 	    (if number1
 		(if number2
 		    (calculate operator-pair number1 number2)
@@ -79,7 +79,7 @@
 			       "Please enter a valid second number."))
 		(show-page operator-pair number1 number2 
 			   "Please enter a valid first number.")))
-	  ((input-field-binding change-button bindings)
+	  ((returned-via? change-button bindings)
 	   (with-fatal-error-handler
 	    (lambda (c d)
 	      ;; This should never happen.