+ major change in internal representation of forms and its elements

+ SERVLET-FORM now introduces a special form with our input-fields
+ servlet-forms may be nested

scheme/httpd/surflets/surflets.scm

@@ -90,38 +90,66 @@
 ;; extended by additional port argument
 (define (servlet-XML->HTML out html-tree)
   (formated-reply out
-   (pre-post-order html-tree
+		  (reformat html-tree)))
-	       ;; Universal transformation rules. Work for every HTML,
+
+(define (reformat html-tree)
+  (pre-post-order 
+   html-tree
+   `(
+     ;; Universal transformation rules. Works for every HTML,
      ;; present and future
-    `(,@default-rules
+     ,@default-rules
-      (form *preorder* . 
+     (input-field 
-	    ,(lambda (trigger call-back-function . elems)
+      *preorder*
-	       (list "<form method=\"GET\" action=\"" call-back-function 
+      . ,(lambda (trigger input-field)
-		     (if (and (pair? elems) (pair? (car elems)) (eq? '@ (caar elems)))
+	   (reformat (input-field-HTML-tree input-field))))
-			 (list (car elems) "\">\n" (parse-form-elems (cdr elems)) "</form>")
-			 (list "\">\n" (parse-form-elems elems) "</form>"))))))
      
-    )))
+     (servlet-form 
+       ;; Must do something to prevent the callback-function string to
+       ;; be HTML escaped.
+       *preorder*
+       . ,(lambda (trigger call-back-function . elems)
+	     (if (and (pair? elems)
+		      (XML-attribute? (car elems)))
+		 (make-servlet-form call-back-function (cdar elems) (cdr elems))
+		 (make-servlet-form call-back-function'() elems)))))
+  ))
 
-(define (parse-form-elems elems)
+(define (make-servlet-form call-back-function attributes elems)
-  (map (lambda (elem)
+  `("<form" ,@(map (lambda (attribute-value)
-	 (if (input-field? elem)
+		     ((enattr (car attribute-value)) (cadr attribute-value)))
-	     (post-order (input-field-HTML-tree elem) default-rules)
+		   `((method "GET")
-	     (post-order elem default-rules)))
+		     (action ,call-back-function)
-       elems))
+		     ,@attributes))
+    #\> #\newline
+    ,(reformat elems)
+    "</form>"))
 
-(define text-html-rule
+(define (XML-attribute? thing)
-  `(*text* . ,(lambda (trigger str) 
+  (and (pair? thing)
-		(if (string? str) (string->goodHTML str) str))))
+       (eq? '@ (car thing))))
-(define default-rules
+
-  `((@		; local override for attributes
+(define attribute-rule
+  `(@		; local override for attributes
     ((*default*       
       . ,(lambda (attr-key . value) ((enattr attr-key) value))))
-     . ,(lambda (trigger . value) (list '@ value)))
+    . ,(lambda (trigger . value) (list '@ value))))
-    (*default* . ,(lambda (tag . elems) (apply (entag tag) elems)))
+
-    ,text-html-rule
+(define text-rule
-    (URL . ,(lambda (tag URI text) (list "<a href=\"" URI "\">" text "</a>"))))
+  `(*text*
-  )
+    . ,(lambda (trigger str) 
+	 (if (string? str) (string->goodHTML str) str))))
+
+(define URL-rule
+  (cons 'URL 
+	(lambda (tag URI text) (list "<a href=\"" URI "\">" text "</a>"))))
+
+(define default-rules
+ `(,attribute-rule
+   (*default* 
+    . ,(lambda (tag . elems) (apply (entag tag) elems)))
+   ,text-rule
+   ,URL-rule))
 
 (define (make-callback function)
   (call-with-current-continuation
@@ -131,8 +159,20 @@
 	    (bindings (form-query (http-url:search (request:url req)))))
        (function bindings)))))
 
+
+
+
+
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; input-fields
+;;; defines input-fields for servlets
+
 (define-record-type input-field :input-field
-  (make-input-field name transformer HTML-tree)
+  (real-make-input-field name transformer HTML-tree)
   input-field?
   (name input-field-name)
   (transformer input-field-transformer)
@@ -152,6 +192,9 @@
 
 (define identity (lambda (a) a))
 
+(define (make-input-field name transformer HTML-tree)
+  (list 'input-field (real-make-input-field name transformer HTML-tree)))
+
 (define (make-text-input-field . maybe-further-attributes)
   (let ((name (generate-input-field-name "text")))
     (make-input-field name
@@ -162,7 +205,8 @@
 
 (define (make-number-input-field . maybe-further-attributes)
   (let ((name (generate-input-field-name "number")))
-    (make-input-field name
+    (make-input-field 
+     name
      (lambda (string)
        (or (string->number string)
 	   (error "wrong type")))
@@ -172,7 +216,8 @@
 
 (define (make-password-input-field . maybe-further-attributes)
   (let ((name (generate-input-field-name "password")))
-    (make-input-field name
+    (make-input-field 
+     name
      identity
      `(input (@ (type "password")
 		(name ,name)
@@ -184,7 +229,8 @@
 			       (string? (car maybe-further-attributes)))
 			  (car maybe-further-attributes)
 			  '())))
-    (make-input-field name
+    (make-input-field 
+     name
      identity
      `(textarea (@ (type "textarea")
 		   (name ,name)
@@ -193,7 +239,8 @@
 
 (define (make-select-input-field options . maybe-further-attributes)
   (let ((name (generate-input-field-name "select")))
-    (make-input-field name
+    (make-input-field 
+     name
      (lambda (select)
        select)		;FIXME[extension] refer to list elements
      `(select (@ ((name ,name)
@@ -208,7 +255,8 @@
 ;; in work
 (define (make-radio-input-field values . maybe-further-attributes)
   (let ((name (generate-input-field-name "radio")))
-    (make-input-field name
+    (make-input-field
+     name
      (lambda (select)
        select)	;FIXME refer to list elements
      (map (lambda (value)
@@ -238,14 +286,18 @@
 		 ,@maybe-further-attributes))))
 		    
 (define (input-field-value input-field bindings)
+  (let ((input-field (cadr input-field)))
     (cond
      ((assoc (input-field-name input-field) bindings) =>
       (lambda (binding)
 	((input-field-transformer input-field) (cdr binding))))
      (else
-    (error "no such input-field" input-field bindings))))
+      (error "no such input-field" input-field bindings)))))
 
 
+
+
+;;; tests
 (define number-input-field (make-number-input-field))
 
 (define test 
@@ -256,3 +308,5 @@
      (p (form "return-URI" (table (tr (td "Enter a number ") (td ,number-input-field )))
 	      ,(make-submit-button))))))
 
+
+