! Redesign of input-fields.

+ Split input-fields into two structures:
  + surflets/my-input-fields allows you to create your own input-fields.
    (complete with structure surflets/input-field-value)
  + surflets/surflet-input-fields are the proposals for input-fields
    from SUrflets. They support annotated input-fields where
    appropriate (select, radio, checkbox, hidden) and changing of attributes,
    e.g. default values. See test.scm for examples.
  The interface of the structure SURFLETS has only changed slightly
  concerning the input fields
  (make-higher-input-field --> make-multi-input-field should be the
  main change)
+ Adapt examples to new input-field interface
+ Note new structures in documentation.

scheme/httpd/surflets/input-fields.scm

@@ -5,248 +5,140 @@
 ;;; input-fields
 ;;; defines input-fields for surflets
 
+;;; Globals
 (define *input-field-trigger* `*input-field*)
+(define generate-input-field-name generate-unique-name)
 
-;; GET-BINDINGS?: Transformer will get all bindings of request, not
+;;; Data structure for real-input-field
-;; only the one concerning the input-field.
+;; MULTI?: Transformer will get all bindings of request, not only the
-(define-record-type input-field :input-field
+;; one concerning the input-field.
-  (real-make-input-field name transformer html-tree get-bindings?)
+(define-record-type real-input-field :real-input-field
+  (make-real-input-field name type transformer
+			 attributes html-tree-maker
+			 html-tree multi?)
   real-input-field?
-  (name input-field-name)
+  (name real-input-field-name)
-  (transformer input-field-transformer)
+  (type real-input-field-type)
-  (attributes input-field-attributes)
+  (transformer real-input-field-transformer)
-  (html-tree input-field-html-tree)
+  (attributes real-input-field-attributes set-real-input-field-attributes!)
-  (get-bindings? input-field-get-bindings?))
+  (html-tree-maker real-input-field-html-tree-maker)
+  (html-tree real-input-field-html-tree set-real-input-field-html-tree!)
+  (multi? real-input-field-multi?))
 
-(define-record-discloser :input-field
+(define-record-discloser :real-input-field
   (lambda (input-field)
-    (list 'input-field
+    (list 'real-input-field
-	  (input-field-name input-field))))
+	  (real-input-field-type input-field)
+	  (real-input-field-name input-field))))
+
+(define-syntax with-real-input-field
+  (lambda (expr rename compare)
+    (let ((%if (rename 'if))
+	  (%let (rename 'let))
+	  (%cadr (rename 'cadr))
+	  (%input-field? (rename 'input-field?))
+	  (%error (rename 'error))
+	  (input-field (cadr expr))
+	  (body (cddr expr)))
+      `(,%if (,%input-field? ,input-field)
+	     (,%let ((real-input-field (,%cadr ,input-field)))
+		    ,@body)
+	     (,%error "Invalid argument. Function wants an input-field." 
+		      ,input-field)))))
+
+
+;;; Fake input-field record. This is necessary, as the trigger in SXML
+;;; may only be symbols, not arbitrary values. Thus, our input-fields
+;;; must be preceeded by a trigger symbol to get recognized by the
+;;; SXML transforming routines like sxml->html.
+
+;; Constructors: make-input-field, make-multi-input-field
+
+;; Predicates: input-field?
+
+;; Selectors: input-field-name, input-field-type,
+;; input-field-transformer, input-field-attributes,
+;; input-field-html-tree-maker, input-field-html-tree,
+;; input-field-multi?
+
+;; Mutators: set-input-field-attributes!, touch-input-field!
+
+;;; Constructors for input-field / multi-input-field
+(define (make-input-field name type transformer attributes 
+			  html-tree-maker)
+  (make-sxml-input-field
+   (make-real-input-field name type transformer 
+			  attributes html-tree-maker #f #f)))
+
+(define (make-multi-input-field name type transformer attributes 
+				html-tree-maker)
+  (make-sxml-input-field
+   (make-real-input-field name type transformer 
+			  attributes html-tree-maker #f #t)))
+
+(define (make-sxml-input-field real-input-field)
+  (list *input-field-trigger* real-input-field))
 
-;; Have to do a trick to get around with SSAX: input-field is a list
-;; whose first element is *input-field-trigger* and the last (next) one
-;; is a real input-field.
 (define (input-field? input-field)
   (and (pair? input-field)
        (eq? *input-field-trigger* (car input-field))
        (real-input-field? (cadr input-field))))
 
-(define generate-input-field-name generate-unique-name)
 
-(define identity (lambda (a) a))
+(define (make-input-field-selector selector)
+  (lambda (input-field)
+    (with-real-input-field input-field 
+      (selector real-input-field))))
 
-;; See note at input-field? for reasons for the list.
+(define (make-input-field-setter setter . maybe-reset?)
-(define (make-input-field name transformer html-tree)
+  (let ((reset? (:optional maybe-reset? #f)))
-  (list *input-field-trigger* 
+    (lambda (input-field value)
-	(real-make-input-field name transformer html-tree #f)))
+      (with-real-input-field input-field
+	(if reset?
+	    (set-real-input-field-html-tree! real-input-field #f))
+	(setter real-input-field value)))))
 
-(define (make-higher-input-field transformer html-tree)
+(define input-field-name (make-input-field-selector real-input-field-name))
-  (list *input-field-trigger* 
+(define input-field-type (make-input-field-selector real-input-field-type))
-	(real-make-input-field #f transformer html-tree #t)))
+(define input-field-transformer 
+  (make-input-field-selector real-input-field-transformer))
+(define input-field-attributes 
+  (make-input-field-selector real-input-field-attributes))
+(define input-field-html-tree-maker
+  (make-input-field-selector real-input-field-html-tree-maker))
+(define (input-field-html-tree input-field)
+  (with-real-input-field input-field
+    (cond
+     ((real-input-field-html-tree real-input-field)
+      => identity)
+     (else 
+      (let ((html-tree ((real-input-field-html-tree-maker real-input-field)
+			input-field)))
+	(set-real-input-field-html-tree! real-input-field html-tree)
+	html-tree)))))
 
-(define (make-text-input-field . maybe-further-attributes)
+(define input-field-multi?
-  (let ((name (generate-input-field-name "text")))
+  (make-input-field-selector real-input-field-multi?))
-    (optionals maybe-further-attributes 
-	((default-text string?)
-	 (attributes sxml-attribute?))
-      (make-input-field name
-			identity
-			`(input (@ (type "text")
-				   (name ,name)
-				   ,(and default-text `(value ,default-text))
-				   ;; this will insert a list, but
-				   ;; XML->HTML doesn't care about it
-				   ,(and attributes (cdr attributes))
-				   ))))))
 
-(define make-number-input-field
+(define set-input-field-attributes! (make-input-field-setter set-real-input-field-attributes! #t))
-  (let ((number-input-field-transformer
+;; not exported:
-	 (lambda (string)
+(define set-input-field-html-tree! (make-input-field-setter set-real-input-field-html-tree!))
-	   (or (string->number string)
-	       (error "wrong type")))
-	 ))
-    (lambda maybe-further-attributes
-      (let ((name (generate-input-field-name "number")))
-	(optionals maybe-further-attributes
-	    ((default (lambda (a) (or (number? a)
-				      (string-or-symbol? a))))
-	     (attributes sxml-attribute?))
-	  (make-input-field
-	   name
-	   number-input-field-transformer
-	   `(input (@ (type "text")
-		      (name ,name)
-		      ,(and default `(value ,default))
-		      ,(and attributes (cdr attributes))))))))))
 
-(define (make-password-input-field . maybe-further-attributes)
+;; A touched input-field's html-tree will be recalculated if
-  (let ((name (generate-input-field-name "password")))
+;; neccessary.
-    (optionals maybe-further-attributes
+(define (touch-input-field! input-field)
-	((attributes sxml-attribute?))
+  (set-input-field-html-tree! input-field #f))
-      (make-input-field 
-       name
-       identity
-       `(input (@ (type "password")
-		  (name ,name)
-		  ,(and attributes (cdr attributes))))))))
-
-(define (make-textarea-input-field .  maybe-further-attributes)
-  (let ((name (generate-input-field-name "textarea")))
-    (optionals maybe-further-attributes
-	((default-text string?)
-	 (attributes sxml-attribute?))
-      (make-input-field 
-       name
-       identity
-       `(textarea (@ (type "textarea")
-		     (name ,name)
-		     ,(and attributes (cdr attributes)))
-		  ,(and default-text))))))
-
-;(make-select-input-fields '("this" "that" "those") '(@ ((id "sushi"))))
-;(make-select-input-fields '("this" ("that" '(@ (selected))) "those"))
-;; dropdown: (size 1)
-;; multiple choice: (multiple)
-;; preselected option: (selected)
-;; changed return value: (value new-value)
-;; returns a select input field with several options
-(define make-select-input-field 
-  (let ((make-multiple-transformer
-	 (lambda (name)
-	   (lambda (bindings)
-	     (map cdr
-		  (filter (lambda (binding)
-			    (equal? (car binding) name))
-			  bindings))))))
-
-    (lambda (options . maybe-further-attributes)
-      (optionals maybe-further-attributes
-	    ((multiple? boolean?)
-	     (attributes sxml-attribute?))
-	(let* ((name (generate-input-field-name "select"))
-	       (sxml-options 
-		(map (lambda (option)
-		       (cond
-			((string-or-symbol? option) 
-			 (list 'option option))
-			((list? option) 
-			 (cond
-			  ((null? (cdr option))
-			   `(option ,option))
-			  ((sxml-attribute? (cdr option)) ; w/attribs?
-			   `(option ,(cdr option) ,(car option)))
-			  (else
-			   (error "not an attribute" (cdr option)))))
-			(else
-			 (error "not an option" option))))
-		     options))
-	       (sxml `(select (@ ((name ,name)
-				 ,(if multiple? '(multiple) '())
-				 ,(and attributes (cdr attributes))))
-			     #\newline
-			     ,sxml-options)))
-	  (if multiple?
-	      (make-higher-input-field (make-multiple-transformer name) sxml)
-	      (make-input-field name identity sxml)))))))
-
-;; returns a *list* of radio buttons
-(define (make-radio-input-fields values . maybe-further-attributes)
-  (let ((name (generate-input-field-name "radio")))
-    (optionals maybe-further-attributes
-	((attributes sxml-attribute?))
-      (map (lambda (value)
-	     (let ((value-value (if (pair? value) (car value) value))
-		   (value-attributes (if (pair? value)
-					 (if (sxml-attribute? (cdr value))
-					     (cddr value)
-					     (error "not an attribute" cdr value))
-					 #f)))
-	       (make-input-field
-		name
-		(lambda (select)
-		  select)
-		`(input (@ ((type "radio")
-			    (name ,name)
-			    (value ,value-value)
-			    ,(and value-attributes)
-			    ,(and attributes (cdr attributes))))))))
-	   values))))
-       
-;; returns a checkbox input field
-(define (make-checkbox-input-field . maybe-further-attributes)
-  (let* ((name (generate-input-field-name "checkbox")))
-    (optionals maybe-further-attributes
-	((checked? boolean?)
-	 (value (lambda (a) (or (string? a) 
-				(number? a)
-				(symbol? a))))
-	 (attributes sxml-attribute?))
-      (make-input-field
-       name
-       (lambda (value)
-	 (or (string=? value "on")
-	     value))
-       `(input (@ ((type "checkbox")
-		   (name ,name)
-		   ,(if value `(value ,value) '())
-		   ,(if checked? '(checked) '())
-		   ,(and attributes (cdr attributes)))))))))
-			   
-
-(define (make-hidden-input-field value . maybe-further-attributes)
-  (let ((name (generate-input-field-name "hidden")))
-    (optionals maybe-further-attributes
-	((attributes sxml-attribute?))
-      (make-input-field name
-			identity
-			`(input (@ (type "hidden")
-				   (name ,name)
-				   (value ,value)
-				   ,(and attributes (cdr attributes))))))))
-
-(define (make-button type name button-caption attributes)
-  (make-input-field name
-		    identity
-		    `(input (@ (type ,type)
-			       (name ,name)
-			       ,(and button-caption `(value ,button-caption))
-			       ,(and attributes (cdr attributes))))))
-
-(define (string-or-symbol? a) 
-  (or (string? a)
-      (symbol? a)))
-
-(define (make-submit-button . maybe-further-attributes)
-  (optionals maybe-further-attributes
-      ((button-caption string-or-symbol?)
-       (attributes sxml-attribute?))
-    (make-button "submit" (generate-input-field-name "submit")
-		 button-caption attributes)))
-
-(define (make-reset-button . maybe-further-attributes)
-  (optionals maybe-further-attributes
-      ((button-caption string-or-symbol?)
-       (attributes sxml-attribute?))
-    (make-button "reset" (generate-input-field-name "reset")  
-		 button-caption attributes)))
-
-(define (make-image-button image-source . maybe-further-attributes)
-  (optionals maybe-further-attributes
-      ((attributes sxml-attribute?))
-    (make-button "image"  (generate-input-field-name "imgbtn")
-		 #f `(@ (src ,image-source) 
-			,@(if attributes (cdr attributes) '())))))
 
 ;; <input-field>: '(input-field . <real-input-field>)
-;; <real-input-field>: #{Input-field "name"}
+;; <real-input-field>: #{Real-input-field "name"}
 (define (raw-input-field-value input-field bindings)
-  (let ((input-field (cadr input-field)))
+  (let ((real-input-field (cadr input-field)))
     (cond
-     ((input-field-get-bindings? input-field)
+     ((real-input-field-multi? real-input-field)
-      ((input-field-transformer input-field) bindings))
+      ((real-input-field-transformer real-input-field) bindings))
-     ((real-input-field-binding input-field bindings) =>
+     ((real-input-field-binding real-input-field bindings) =>
       (lambda (binding)
-	((input-field-transformer input-field) (cdr binding))))
+	((real-input-field-transformer real-input-field) (cdr binding))))
      (else
       (error "no such input-field" input-field bindings)))))
 
@@ -263,12 +155,15 @@
   (let ((default (:optional maybe-default #f)))
     (with-fatal-error-handler
      (lambda (condition more)
+;       (format #t "hit error condition: ~s~%" condition)
        default)
      (raw-input-field-value input-field bindings))))
 
 (define (real-input-field-binding input-field bindings)
-  (assoc (input-field-name input-field) bindings))
+  (assoc (real-input-field-name input-field) bindings))
 
 (define (input-field-binding input-field bindings)
   (real-input-field-binding (cadr input-field) bindings))
 
+
+;;EOF

scheme/httpd/surflets/packages.scm

@@ -64,6 +64,7 @@
 	  sxml->string
 	  sxml->string/internal
 	  sxml-attribute?
+	  sxml-attribute-attributes
 	  default-rule
 	  text-rule
 	  attribute-rule))
@@ -75,6 +76,7 @@
 	  surflet-form-rule
 	  default-rules
 	  plain-html-rule
+	  nbsp-rule
 	  url-rule))
 
 ;; Use for advanced users: make your own conversion rules.
@@ -100,8 +102,8 @@
 	  set-session-data!))
 
 ;; Use for advanced users: access to your sessions and continuations
-;; and continuations (currently you get access to all sessions; this
+;; (currently you get access to all sessions; this should and will be
-;; should and will be restricted in the future)
+;; restricted in the future)
 (define-interface surflets/my-sessions-interface
   (compound-interface 
    surflets/ids-interface
@@ -274,41 +276,82 @@
   (export typed-optionals
 	  (optionals :syntax)))
 
-
+;; Input-fields as Scheme-Objects
-
+(define-interface surflets/input-field-value-interface
-;; Input-fields as Scheme objects
+  (export input-field?
-(define-interface surflets/input-fields-interface
-  (export generate-input-field-name
-	  make-input-field
-	  make-higher-input-field
-	  make-text-input-field
-	  make-hidden-input-field
-	  make-password-input-field
-	  make-number-input-field
-	  make-textarea-input-field
-	  make-select-input-field
-	  make-checkbox-input-field
-	  make-radio-input-fields
-
-	  make-submit-button
-	  make-reset-button
-	  make-image-button
-	  input-field-value
 	  raw-input-field-value
-	  input-field-binding
+	  input-field-value
-	  input-field?))
+	  input-field-binding))
 
-;;; This is for surflets/surflet-sxml only:
+;; For advanced users: creating your own input-fields
-(define-interface surflets/input-fields/internal-interface
+(define-interface surflets/my-input-fields-interface
-  (export *input-field-trigger*
+  (compound-interface 
-	  input-field-html-tree))
+   surflets/input-field-value-interface
+   (export *input-field-trigger*
+	   generate-input-field-name
+	   make-input-field
+	   make-multi-input-field
+	   input-field-name
+	   input-field-type
+	   input-field-transformer
+	   input-field-attributes 
+	   input-field-html-tree-maker
+	   input-field-html-tree
+	   input-field-multi?
+	   set-input-field-attributes!
+	   touch-input-field!)))
+
+(define-interface surflets/surflet-input-fields-interface
+  (compound-interface
+   surflets/input-field-value-interface
+   (export make-text-input-field
+	   set-text-input-field-value!
+
+	   make-number-input-field
+	   set-number-input-field-value!
+
+	   make-hidden-input-field
+	   set-hidden-input-field-value!
+	   
+	   make-password-input-field
+	   set-password-input-field-value!
+
+	   make-textarea-input-field
+	   set-textarea-input-field-value!
+
+	   make-select-input-field
+	   make-annotated-select-input-field
+	   make-simple-sel-if-option
+	   make-annotated-sel-if-option
+	   sel-if-option?
+	   select-sel-if-option!
+	   unselect-sel-if-option!
+	   set-sel-if-option-selected?!
+	   
+	   make-radio-input-field-group
+	   make-annotated-radio-input-field-group
+	   make-radio-input-fields
+	   check-radio-input-field!
+	   uncheck-radio-input-field!
+	   set-radio-input-field-checked?!
+
+	   make-checkbox-input-field
+	   make-annotated-checkbox-input-field
+	   check-checkbox-input-field!
+	   uncheck-checkbox-input-field!
+	   set-checkbox-input-field-checked?!
+
+	   make-submit-button
+	   make-reset-button
+	   make-image-button)))
 
 ;; Some utilities
 (define-interface surflets/utilities-interface
   (export form-query-list
 	  rev-append
 	  generate-unique-number
-	  generate-unique-name))
+	  generate-unique-name
+	  identity))
 
 ;; Intelligent Addresses
 (define-interface surflets/addresses-interface
@@ -358,7 +401,7 @@
 ;   surflets/sxml-interface
 ;   surflets/surflet-sxml-interface
    surflets/send-html-interface
-   surflets/input-fields-interface
+   surflets/surflet-input-fields-interface
    surflets/addresses-interface
    surflets/returned-via-interface
    surflets/bindings-interface
@@ -412,7 +455,7 @@
 (define-structure surflets surflets-interface
   (open	surflets/session-data
 	surflets/send-html		;send-html/suspend...
-	surflets/input-fields
+	surflets/surflet-input-fields
 	surflets/addresses		;annotated-address...
 	surflets/returned-via
 	surflets/bindings))
@@ -460,6 +503,7 @@
 	define-record-types
 	let-opt
 	surflets
+	surflets/surflet-input-fields
 	(subset srfi-1 (zip filter find make-list))
 	handle-fatal-error
 	)
@@ -511,26 +555,40 @@
 
 ;; Input fields as Scheme objects
 (define-structures 
-  ((surflets/input-fields surflets/input-fields-interface)
+  ((surflets/input-field-value surflets/input-field-value-interface)
-   (surflets/input-fields/internal 
+   (surflets/my-input-fields surflets/my-input-fields-interface))
-    surflets/input-fields/internal-interface))
+  (open scheme-with-scsh		;error, format
-  (open scheme
-	srfi-23				;error
-	(subset srfi-1 (filter))
 	(subset let-opt (:optional))
 	handle-fatal-error
 	define-record-types
-	(subset typed-optionals (optionals))
 	surflets/sxml
-	surflets/utilities		;rev-append,generate-unique-name
+	surflets/utilities
 	)
   (files input-fields))
 
+(define-structure surlfets/input-fields surflets/my-input-fields)
+
+(define-structure surflets/surflet-input-fields
+  surflets/surflet-input-fields-interface
+  (open scheme-with-scsh		;error, format
+	;; avoid name collision for member
+	(modify srfi-1 (rename (member member/srfi-1)))
+	define-record-types
+	(subset let-opt (:optional))
+	(subset typed-optionals (optionals))
+	surflets/my-input-fields
+	surflets/utilities		;generate-unique-number
+	surflets/sxml
+	tables				;make-integer-table
+	)
+  (files surflet-input-fields))
+
 
 ;; Extensions to SXML for surflets
 (define-structure surflets/surflet-sxml surflets/surflet-sxml-interface
   (open scheme-with-scsh		;error,receive
-	surflets/input-fields/internal
+	(subset surflets/my-input-fields
+		(*input-field-trigger* input-field-html-tree))
 	surflets/sxml
 	typed-optionals
 	(subset sxml-tree-trans (pre-post-order)))
@@ -578,7 +636,7 @@
 
 (define-structure surflets/returned-via surflets/returned-via-interface
   (open scheme
-	surflets/input-fields
+	surflets/input-field-value
 	surflets/addresses
 	(subset uri (unescape-uri)))
   (files returned-via))

scheme/httpd/surflets/surflet-input-fields.scm

@@ -0,0 +1,472 @@
+;;; SUrflets' input fields
+;;; Copyright 2002, 2003 Andreas Bernauer
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Functions to create simple input fields
+
+;; The interface for input-fields does not prescribe what the type of
+;; attributes has to be. We choose a record here.
+
+(define-record-type input-field-attributes :input-field-attributes
+  (make-input-field-attributes default others)
+  input-field-attributes?
+  (default input-field-attributes-default set-input-field-attributes-default!)
+  (others input-field-attributes-others set-input-field-attributes-others!))
+
+;; A simple input-field is a prototype for other input-fields.
+;; REPORTED-TYPE is the type of the input-field in HTML, TYPE the
+;; internal referenced type and TRANSFORMER the function that
+;; translates the HTTP-string of the request into a scheme value.
+(define (simple-input-field-maker reported-type type default-pred transformer)
+  (lambda maybe-further-attributes
+    (let ((name (generate-input-field-name type)))
+      (optionals maybe-further-attributes 
+	  ((default default-pred)
+	   (attributes sxml-attribute?))
+	(make-input-field name type
+			  transformer
+			  (make-input-field-attributes
+			   (and default `(value ,default))
+			   (sxml-attribute-attributes attributes))
+			  (simple-input-field-maker-html-tree-maker 
+			   reported-type))))))
+
+(define (simple-input-field-maker-html-tree-maker reported-type)
+  (lambda (input-field)
+    (let ((attributes (input-field-attributes input-field)))
+      `(input (@ (type ,reported-type)
+		 (name ,(input-field-name input-field))
+		 ,(input-field-attributes-default attributes)
+		 ,(input-field-attributes-others attributes))))))
+
+(define (make-simple-input-field-default-setter default-pred? wrap?)
+  (lambda (input-field value)
+    (if (default-pred? value)
+	(set-input-field-attributes-default! 
+	 (input-field-attributes input-field) 
+	 (if wrap? `(value ,value) value))
+	(error "Default value must be a number or a string or a symbol." 
+	       value))
+    (touch-input-field! input-field)))
+
+(define (string-or-symbol? thing) 
+  (or (string? thing) (symbol? thing)))
+(define simple-default? string-or-symbol?)
+
+(define set-simple-input-field-default!
+  (make-simple-input-field-default-setter simple-default? #t))
+
+;;;;;;;;;;;;;;;;;;;;
+;;; Text input field
+(define make-text-input-field 
+  (simple-input-field-maker "text" "text" 
+			    simple-default? identity))
+(define set-text-input-field-value! set-simple-input-field-default!)
+
+;;;;;;;;;;;;;;;;;;;;;;
+;;; Number input field
+(define (number-input-field-default? value)
+  (or (number? value)
+      (simple-default? value)))
+(define (number-input-field-transformer string)
+  (or (string->number string)
+      (error "wrong type")))
+(define make-number-input-field
+  (simple-input-field-maker "text" "number"
+			    number-input-field-default?
+			    number-input-field-transformer))
+(define set-number-input-field-value!
+  (make-simple-input-field-default-setter number-input-field-default? #t))
+
+;;;;;;;;;;;;;;;;;;;;;;
+;;; hidden input-field
+;; Little workaraound, as a hidden input-field needs a value. This
+;; value is propagated in the slot "default value".
+(define make-hidden-input-field
+  (let ((hidden-input-field-generator 
+	 (simple-input-field-maker "hidden" "text" 
+				   simple-default? identity)))
+    (lambda (value . maybe-further-attributes)
+      (apply hidden-input-field-generator
+	     (cons value maybe-further-attributes)))))
+(define set-hidden-input-field-value! 
+  set-simple-input-field-default!)
+
+;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Password input field
+(define make-password-input-field 
+  (simple-input-field-maker "password" "password" 
+			    simple-default? identity))
+(define set-password-input-field-value!
+  set-simple-input-field-default!)
+
+;;; That's it for simple input fields.
+
+;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Textarea input field
+(define (make-textarea-input-field .  maybe-further-attributes)
+  (let ((name (generate-input-field-name "textarea")))
+    (optionals maybe-further-attributes
+	((default-text simple-default?)
+	 (attributes sxml-attribute?))
+      (make-input-field 
+       name "textarea"
+       identity
+       (make-input-field-attributes
+	(and default-text)
+	(sxml-attribute-attributes attributes))
+       make-textarea-input-field-html-tree))))
+
+(define (make-textarea-input-field-html-tree input-field)
+  (let ((attributes (input-field-attributes input-field)))
+    `(textarea (@ (type "textarea")
+		  (name ,(input-field-name input-field))
+		  ,(input-field-attributes-others attributes))
+	       ,(input-field-attributes-default attributes))))
+
+(define set-textarea-input-field-value!
+  (let ((textarea-default-setter!
+	 (make-simple-input-field-default-setter simple-default? #f)))
+    (lambda (textarea-input-field value)
+      (textarea-default-setter! textarea-input-field value))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Selection input field
+
+;; sel-if == select-input-field
+;(make-select-input-fields '("this" "that" "those") '(@ ((id "sushi"))))
+;(make-select-input-fields '("this" ("that" '(@ (selected))) "those"))
+;; dropdown: (size 1)
+
+;;; A selection input field shows a list of options that can be
+;;; selected. For this purpose, we introduce an sel-if-option record,
+;;; that contains all the information for each option. This is
+;;; justified by the fact, that the options list is in HTML seperated,
+;;; too.
+(define-record-type sel-if-option :sel-if-option
+  (really-make-sel-if-option tag value selected? attributes)
+  sel-if-option?
+  (tag sel-if-option-tag)
+  (value sel-if-option-value)
+  (selected? sel-if-option-selected? set-sel-if-option-selected?!)
+  (attributes sel-if-option-attributes set-sel-if-option-attributes!))
+
+(define (make-sel-if-option tag value selected? attributes)
+  (if (string? tag)
+      (really-make-sel-if-option tag value selected?
+				 (sxml-attribute-attributes attributes))
+      (error "Select-input-field-option's tag must be a string." tag)))
+
+;; Constructor for valued select input-field option.
+(define (make-annotated-sel-if-option tag value . maybe-attributes)
+  (optionals maybe-attributes
+      ((selected? boolean?)
+       (attributes sxml-attribute?))
+    (make-sel-if-option tag value selected? attributes)))
+
+;; Constructor for a simple select input-field option (not annotated).
+(define (make-simple-sel-if-option tag . maybe-attributes)
+  (optionals maybe-attributes
+      ((selected? boolean?)
+       (attributes sxml-attribute?))
+    (make-sel-if-option tag 'ignored selected? attributes)))
+
+(define-record-discloser :sel-if-option
+  (lambda (sel-if-option)
+    (list 'select-input-field-option
+	  (sel-if-option-tag sel-if-option)
+	  (sel-if-option-value sel-if-option)
+	  (sel-if-option-selected? sel-if-option)
+	  (sel-if-option-attributes sel-if-option)
+	  )))
+
+;; Selecting / Unselecting of an option in an select input-field,
+;; chosen by tag.
+(define (select-sel-if-option! tag sel-if)
+  (set-select-input-field-option-selected?! tag sel-if #t))
+
+(define (unselect-sel-if-option! tag sel-if)
+  (set-select-input-field-option-selected?! tag sel-if #f))
+
+(define (set-select-input-field-option-selected?! tag sel-if selected?)
+  (let ((options (input-field-attributes-default 
+		  (input-field-attributes sel-if))))
+    (if (number? tag)
+	(set-sel-if-option-selected?! (list-ref options tag) 
+				      selected?)
+	(let lp ((options options))
+	  (if (null? options)
+	      (error "No such option" tag sel-if)
+	      (if (tag=sel-if-option? tag (car options))
+		  (set-sel-if-option-selected?! (car options) selected?)
+		  (lp (cdr options))))))
+    (touch-input-field! sel-if)))
+
+;; Find sel-if-option in a list by its tag.
+(define (tag=sel-if-option? tag sel-if-option)
+  (string=? tag (sel-if-option-tag sel-if-option)))
+
+(define (find-sel-if-option tag sel-if-options)
+  (cond ((member/srfi-1 tag sel-if-options tag=sel-if-option?)
+	 => car)
+	(else #f)))
+
+(define (find-sel-if-option-value tag sel-if-options)
+  (cond ((find-sel-if-option tag sel-if-options)
+	 => sel-if-option-value)
+	(else #f)))
+
+;; To be compatible with previous versions of MAKE-SELECT-INPUT-FIELD,
+;; we accept also a simple list as an option-list. New programs should
+;; use sel-if-options-list (easily createable with 
+;; (map make-simple-sel-if-option option-list))
+(define (tolerate-old-sel-if-options sel-if-options)
+  (if (and (list? sel-if-options)
+	   (every sel-if-option? sel-if-options))
+      sel-if-options
+      (map make-simple-sel-if-option sel-if-options)))
+
+(define (make-select-input-field sel-if-options . maybe-further-attributes)
+  (really-make-select-input-field (tolerate-old-sel-if-options sel-if-options)
+				  #f
+				  maybe-further-attributes))
+
+(define (make-annotated-select-input-field sel-if-options . 
+					   maybe-further-attributes)
+  (really-make-select-input-field sel-if-options #t maybe-further-attributes))
+
+(define (really-make-select-input-field sel-if-options annotated? 
+					maybe-further-attributes)
+  (let ((real-sel-if-options (tolerate-old-sel-if-options sel-if-options)))
+    (optionals maybe-further-attributes
+	((multiple? boolean?)
+	 (attributes sxml-attribute?))
+      (let ((name (generate-input-field-name "select")))
+	(if multiple?
+	    (make-multiple-select-input-field name sel-if-options 
+					      annotated? attributes)
+	    (make-single-select-input-field name sel-if-options 
+					    annotated? attributes))))))
+
+;; internal
+(define (make-multiple-select-input-field name sel-if-options 
+					  annotated? attributes)
+  (make-multi-input-field name "mult-select"
+			  (make-sel-if-multiple-transformer name sel-if-options
+							    annotated?)
+			  (make-input-field-attributes
+			   sel-if-options 
+			   (list '(multiple) 
+				 (sxml-attribute-attributes attributes)))
+			  make-sel-if-html-tree))
+
+;; internal
+(define (make-single-select-input-field name sel-if-options 
+					annotated? attributes)
+  (make-input-field name "select" 
+		    (if annotated?
+			(lambda (tag)
+			  (cond ((find-sel-if-option-value tag sel-if-options)
+				 => identity)
+				(else (error "no such option." tag))))
+			identity)
+		    (make-input-field-attributes
+		     sel-if-options 
+		     (sxml-attribute-attributes attributes))
+		    make-sel-if-html-tree))
+
+(define (make-sel-if-multiple-transformer name sel-if-options annotated?)
+  (lambda (bindings)
+    (let ((tags (map cdr
+		     (filter (lambda (binding)
+			       (equal? (car binding) name))
+			     bindings))))
+      (filter-map (if annotated?
+		      (lambda (tag)
+			(find-sel-if-option-value tag sel-if-options))
+		      (lambda (tag)
+			(if (find-sel-if-option tag sel-if-options)
+			    tag
+			    #f)))
+		  tags))))
+
+(define (make-sel-if-html-tree sel-if)
+  (let ((attributes (input-field-attributes sel-if)))
+    `(select (@ (name ,(input-field-name sel-if))
+		,(input-field-attributes-others attributes))
+	     #\newline
+	     ,@(make-sel-if-options-html-tree 
+		(input-field-attributes-default attributes)))))
+
+(define (make-sel-if-options-html-tree sel-if-options)
+  (map (lambda (sel-if-option)
+	 `(option (@ ,(and (sel-if-option-selected? sel-if-option) '(selected))
+		     ,(sel-if-option-attributes sel-if-option))
+		  ,(sel-if-option-tag sel-if-option)))
+       sel-if-options))
+
+;;;;;;;;;;;;;;;;;;;;;;
+;;; radio input-fields	    
+;; Because grouped radio input-fields must use the same name, we
+;; cannot just return one radio input-field object, but we must
+;; generate several ones with the same name.
+(define (make-radio-input-field-group)
+  (let ((name (generate-input-field-name "radio")))
+    (lambda (value-string . maybe-further-attributes)
+      (optionals maybe-further-attributes
+	  ((checked? boolean?)
+	   (attributes sxml-attribute?))
+	(make-input-field name "radio"
+			  identity
+			  (make-input-field-attributes 
+			   (if checked? '(checked) #f)
+			   (list `(value ,value-string)
+				 (sxml-attribute-attributes attributes)))
+			  radio-input-field-html-tree-maker)))))
+
+(define (make-annotated-radio-input-field-group)
+  (let* ((name (generate-input-field-name "radio"))
+	 (value-table (make-integer-table))
+	 (transformer (make-radio-input-field-transformer value-table)))
+    (lambda (value . maybe-further-attributes)
+      (optionals maybe-further-attributes
+	  ((checked? boolean?)
+	   (attributes sxml-attribute?))
+	(let ((number (generate-unique-number)))
+	  (table-set! value-table number value)
+	  (make-input-field name "radio"
+			    transformer
+			    (make-input-field-attributes 
+			     (if checked? '(checked) #f)
+			     (list`(value ,(number->string number))
+				  (sxml-attribute-attributes attributes)))
+			    radio-input-field-html-tree-maker))))))
+
+(define (make-radio-input-fields values . maybe-further-attributes)
+  (optionals maybe-further-attributes
+      ((attributes sxml-attribute?))
+    (let ((radio-gen (make-annotated-radio-input-field-group)))
+      (map (lambda (value)
+	     (if attributes
+		 (radio-gen value attributes)
+		 (radio-gen value)))
+	   values))))
+
+
+(define (make-radio-input-field-transformer value-table)
+  (lambda (tag)
+    (cond 
+     ((string->number tag) =>
+      (lambda (number)
+	(let ((value (table-ref value-table number)))
+	  (if value
+	      value
+	      (error "Unknown tag number for radio input-field" tag)))))
+     (else
+      (error "Unknown tag number for radio input-field" tag)))))
+
+(define (radio-input-field-html-tree-maker radio-input-field)
+  (let* ((attributes (input-field-attributes radio-input-field)))
+    `(input (@ ((type "radio")
+		(name ,(input-field-name radio-input-field))
+		,(input-field-attributes-default attributes)
+		,(input-field-attributes-others attributes))))))
+
+(define (set-input-field-checked?! input-field checked?)
+  (let ((attributes (input-field-attributes input-field)))
+    (set-input-field-attributes-default! 
+     attributes
+     (if checked? '(checked) #f))
+    (touch-input-field! input-field)))
+     
+(define set-radio-input-field-checked?! set-input-field-checked?!)
+(define (check-radio-input-field! radio)
+  (set-radio-input-field-checked?! radio #t))
+(define (uncheck-radio-input-field! radio)
+  (set-radio-input-field-checked?! radio #f))
+;;;;;;;;;;;;;;;;;;;;;;;;
+;;; checkbox input-field
+(define (make-checkbox-input-field . maybe-further-attributes)
+  (really-make-checkbox-input-field #t
+				    checkbox-transformer
+				    maybe-further-attributes))
+
+(define (make-annotated-checkbox-input-field value . maybe-further-attributes)
+  (really-make-checkbox-input-field value 
+				    (make-checkbox-transformer value)
+				    maybe-further-attributes))
+
+(define (really-make-checkbox-input-field value transformer attributes)
+  (let ((name (generate-input-field-name "checkbox")))
+    (optionals attributes
+	((checked? boolean?)
+	 (attributes sxml-attribute?))
+      (make-input-field name "checkbox"
+			transformer
+			(make-input-field-attributes
+			 (if checked? '(checked) #f)
+			 (sxml-attribute-attributes attributes))
+			checkbox-input-field-html-tree-maker))))
+
+(define (make-checkbox-transformer value)
+  (lambda (tag)
+    (if (string=? tag "on")
+	value
+	#f)))
+
+(define checkbox-transformer
+  (make-checkbox-transformer #t))
+
+(define (checkbox-input-field-html-tree-maker cb-if)
+  (let ((attributes (input-field-attributes cb-if)))
+    `(input (@ ((type "checkbox")
+		(name ,(input-field-name cb-if))
+		,(input-field-attributes-default attributes)
+		,(input-field-attributes-others attributes))))))
+
+(define set-checkbox-input-field-checked?! set-input-field-checked?!)
+(define (check-checkbox-input-field! checkbox)
+  (set-checkbox-input-field-checked?! checkbox #t))
+(define (uncheck-checkbox-input-field! checkbox)
+  (set-checkbox-input-field-checked?! checkbox #f))
+;;;;;;;;;;;;;;;;;;;;;;
+;; button input-fields
+(define (make-button type name button-caption attributes)
+  (make-input-field name type
+		    identity
+		    (make-input-field-attributes
+		     (and button-caption `(value ,button-caption))
+		     (sxml-attribute-attributes attributes))
+		    make-button-html-tree))
+
+(define (make-button-html-tree button-input-field)
+  (let ((attributes (input-field-attributes button-input-field)))
+    `(input (@ (type ,(input-field-type button-input-field))
+	       (name ,(input-field-name button-input-field))
+	       ,(input-field-attributes-default attributes)
+	       ,(input-field-attributes-others attributes)))))
+
+(define (make-submit-button . maybe-further-attributes)
+  (optionals maybe-further-attributes
+      ((button-caption string?)
+       (attributes sxml-attribute?))
+    (make-button "submit" (generate-input-field-name "submit")
+		 button-caption attributes)))
+
+(define (make-reset-button . maybe-further-attributes)
+  (optionals maybe-further-attributes
+      ((button-caption string?)
+       (attributes sxml-attribute?))
+    (make-button "reset" (generate-input-field-name "reset")  
+		 button-caption attributes)))
+
+(define (make-image-button image-source . maybe-further-attributes)
+  (optionals maybe-further-attributes
+      ((attributes sxml-attribute?))
+    (make-button "image"  (generate-input-field-name "imgbtn")
+		 #f `(@ (src ,image-source) 
+			,@(sxml-attribute-attributes attributes)))))
+
+
+
+;;EOF

scheme/httpd/surflets/surflets-structures.txt

@@ -3,7 +3,7 @@ We have three basic layers of structures:            -*- Outline -*-
 * Overview
 (a) Basic User           surflets, simple-surflet-api
 (b) Advanced User        surflets/my-sxml, surflets/my-sessions,
-                         surflets/primitives
+                         surflets/my-input-fields, surflets/primitives
 (c) Administrative User  surflet-handler/admin, profiling
 
 The fourth layer:
@@ -17,12 +17,13 @@ own rules.
       provides:      . sending of html represented by surflet-sxml
                      . using special tags in its surflet-sxml:
                        url, plain-html, surflet-form
-                     . input-fields, input-field-value,...
+                     . input-fields: input-field-value,
+		       input-field-binding, ...
                      . get-bindings, extract-bindings, ...
                      . make-address, make-annotated-address, ...
                      . returned-via?, case-returned-via, ...
 		     . get-session-data, set-session-data!
-                     surflets is splitted in several parts, that can
+                     surflets contains of several parts, that can
                        be loaded independently from each other.
   
 **    structures: (2) simple-surflet-api
@@ -57,7 +58,12 @@ own rules.
                       . session-alive?, session-surflet-name
                       . access to options: options-session-lifetime,
                         options-cache-surflets?
-**    structures: (3) surflet-handler/primitives
+
+**    structures: (3) surflets/my-input-fields
+      provides:     . Access to the primitives of input-fields:
+		    . Constructor, selector, mutators, predicate
+
+**    structures: (4) surflet-handler/primitives
       provides:     . Access to the primitives of the 
                       surflet handler:
                     . send/suspend, ... that send surflet responses
@@ -68,7 +74,6 @@ own rules.
                       (string or list of strings)
                     . surflet-requests...
 
-
 * (c) Administrative User
 **    structures: (1) surflet-handler/admin
       provides:     . Access to all internal structures of the

scheme/httpd/surflets/web-server/root/surflets/byte-input.scm

@@ -1,6 +1,7 @@
 (define-structure surflet surflet-interface
   (open surflets
 	surflet-requests
+	surflets/my-input-fields
 	handle-fatal-error
 	url
 	scheme-with-scsh)
@@ -16,20 +17,22 @@
 		(if (= count bits)
 		    '()
 		    (cons 
-		     (make-checkbox-input-field (number->string order))
+		     (make-annotated-checkbox-input-field order)
 		     (loop (+ 1 count)
 			   (* 2 order))))))))
-	(make-higher-input-field
+	(make-multi-input-field
+	 #f "byte-input"
 	 (lambda (bindings)
 	   (let loop ((sum 0)
 		      (checkboxes checkboxes))
 	     (if (null? checkboxes)
 		 sum
-		 (loop (+ sum (string->number
+		 (loop (+ sum (or (input-field-value (car checkboxes) bindings)
-			       (or (input-field-value (car checkboxes) bindings)
+				  0))
-				   "0")))
 		       (cdr checkboxes)))))
-	 checkboxes)))
+	 '()
+	 (lambda (ignore)
+	   checkboxes))))
 
     (define byte-input-fields (make-byte-input-fields 8))
 

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

@@ -1,5 +1,6 @@
 (define-structure surflet surflet-interface
   (open surflets
+	surflets/my-input-fields
 	surflet-requests
 	handle-fatal-error
 	let-opt
@@ -20,17 +21,18 @@
     (define operator-input-field
       (let ((name (generate-input-field-name "operator")))
 	(make-input-field 
-	 name
+	 name "operator"
 	 (lambda (operator-string)
-	   (cond 
+	   (let ((operator (assoc operator-string *operator-alist*)))
-	    ((assoc operator-string *operator-alist*) =>
+	     (if operator
-	     (lambda (a) a))
+		 operator
-	    (else
+		 (error "no such operator" operator-string))))
-	     (error "no such operator" operator-string))))
+	 '()
-	 `(select (@ (name ,name))
+	 (lambda (input-field)
-		  ,@(map (lambda (operator)
+	   `(select (@ (name ,name))
-			   `(option ,(operator-symbol operator)))
+		    ,@(map (lambda (operator)
-			 *operator-alist*)))))
+			     `(option ,(operator-symbol operator)))
+			   *operator-alist*))))))
 
 
     (define (make-number-input-field/default default)

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

@@ -163,9 +163,9 @@
 	    (and armed?
 		 (map (lambda (type)
 			(let ((text (cdr (assoc type arm-types))))
-			  (cons (make-checkbox-input-field
+			  (cons (make-annotated-checkbox-input-field
-				 (and def-weapons (member? text def-weapons))
+				 text
-				 text)
+				 (and def-weapons (member? text def-weapons)))
 				text)))
 		      (ship-data-arm-types (ship-ref class)))))
 	   (energy-input (and armed?
@@ -215,7 +215,7 @@
 ;;; items are taken from the ship data list.
 (define (get-extras req class)
   (let* ((checkboxes+text (map (lambda (extra)
-				 (cons (make-checkbox-input-field extra)
+				 (cons (make-annotated-checkbox-input-field extra)
 				       (cdr (assoc extra extras))))
 			       (ship-data-extras (ship-ref class))))
 	 (req (send-html/suspend