+ small calculator

+ shows usage of
 ++ callbacks (two submitbuttons)
 ++ creation of own input fields

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

@@ -0,0 +1,87 @@
+(define-structure plugin plugin-interface
+  (open servlets
+	httpd-request
+	scsh
+	scheme)
+  (begin
+
+    ;; This uses callbacks.
+    
+    (define *operator-alist*
+	    `(("+" . ,+)
+	      ("-" . ,-)
+	      ("*" . ,*)
+	      ("/" . ,/)))
+
+    (define operator-symbol car)
+    (define operator-operator cdr)
+
+    (define operator-input-field
+      (let ((name (generate-input-field-name "operator")))
+	(make-input-field 
+	 name
+	 (lambda (operator-string)
+	   (cond 
+	    ((assoc operator-string *operator-alist*) =>
+	     (lambda (a) a))
+	    (else
+	     (error "no such operator" operator-string))))
+	 `(select (@ ((name ,name)))
+		  ,@(map (lambda (operator)
+			   `(option ,(operator-symbol operator)))
+			 *operator-alist*)))))
+
+    (define number-field1 (make-number-input-field))
+    (define number-field2 (make-number-input-field))
+
+    (define change-operator-callback
+      (make-callback 
+       (lambda (bindings)
+	 (change-operator
+	  (input-field-value operator-input-field
+				  bindings)))))
+
+    (define (show-page operator-pair)
+      (send-html
+       `(html 
+	 (title "Simple calculator")
+	 (body (h1 "Simple calculator")
+	       (servlet-form
+		,(make-callback (lambda (bindings)
+				  (calculate operator-pair bindings)))
+		(table
+		 (tr (td "Do calculation:"))
+		 (tr (td ,number-field1) 
+		     (td ,(operator-symbol operator-pair))
+		     (td ,number-field2)
+		     (td " = ")
+		     (td ,(make-submit-button '(value "calculate"))))))
+	       (hr)
+	       (p "You may choose another operator:")
+	       (servlet-form
+		,change-operator-callback
+		(table
+		 (tr (td ,operator-input-field)
+		     (td ,(make-submit-button '(value "change operator"))))))))))
+		     
+    (define (change-operator to-operation)
+      (show-page to-operation))
+
+    (define (calculate operator-pair bindings)
+      (let ((number1 (input-field-value number-field1 bindings))
+	    (number2 (input-field-value number-field2 bindings))
+	    (operator (operator-operator operator-pair)))
+	(show-result number1 (operator-symbol operator-pair) number2
+		     (operator number1 number2))))
+
+    (define (show-result number1 operator-symbol number2 result)
+      (send-html
+       `(html (title "Calculation Result")
+	      (body (h1 "Result")
+		    (p ,number1 " " ,operator-symbol " " ,number2
+		       " = " ,result)))))
+
+    (define (main req)
+      (show-page (car *operator-alist*))
+      (error "This does not return"))
+    ))