+ (foreach downcase! identifiers)

+ fold FORMATED-REPLY into SURFLET-XML->HTML
+ rename REAL-FORMATED-REPLY to FORMATED-REPLY
+ use global value INPUT-FIELD-TRIGGER instead of symbol 'input-field
+ The SURFLET-FORM tag creates a REFORMATted list instead of HTML
Note: There were no changes to the interface.

scheme/httpd/surflets/surflets.scm

@@ -6,7 +6,7 @@
   (send/suspend 
    (lambda (new-url)
      (make-usual-html-response
-      (surflet-XML->HTML #f (html-tree-maker new-url))))))
+      (surflet-xml->html #f (html-tree-maker new-url))))))
 
 (define (send-html/finish html-tree)
   (do-sending send/finish html-tree))
@@ -16,7 +16,7 @@
 
 (define (do-sending send html-tree)
   (send (make-usual-html-response 
-	 (surflet-XML->HTML #f html-tree))))
+	 (surflet-xml->html #f html-tree))))
 
 (define (make-usual-html-response html-string)
   (make-surflet-response
@@ -128,20 +128,7 @@
 ;; #f: string
 ;; port: port
 ;; else: error
-(define (formated-reply port . fragments)
+(define (formated-reply port fragments)
-  (cond 
-   ((not port)
-    (call-with-string-output-port
-     (lambda (port)
-       (real-formated-reply port fragments))))
-   ((eq? port #t)
-    (real-formated-reply (current-output-port) fragments))
-   ((output-port? port)
-    (real-formated-reply port fragments))
-   (else
-    (error "invalid port argument to FORMATED-REPLY" port))))
-
-(define (real-formated-reply port fragments)
   (let loop ((fragments fragments) (result #f))
     (cond
      ((null? fragments) result)
@@ -158,9 +145,20 @@
 
 ;; adapted from Oleg's SXML-to-HTML.scm
 ;; extended by additional port argument
-(define (surflet-XML->HTML out html-tree)
+(define (surflet-xml->html port html-tree)
-  (formated-reply out
+  (let ((fragments (reformat html-tree)))
-		  (reformat html-tree)))
+  (cond 
+   ((not port)
+    (call-with-string-output-port
+     (lambda (port)
+       (formated-reply port fragments))))
+   ((eq? port #t)
+    (formated-reply (current-output-port) fragments))
+   ((output-port? port)
+    (formated-reply port fragments))
+   (else
+    (error "In surflet-xml->html: invalid port argument to FORMATED-REPLY" 
+	   port)))))
 
 (define (reformat html-tree)
   (pre-post-order 
@@ -169,51 +167,54 @@
      ;; Universal transformation rules. Works for every HTML,
      ;; present and future
      ,@default-rules
-     (input-field 
+     (,input-field-trigger
       *preorder*
       . ,(lambda (trigger input-field)
 	   (reformat (input-field-HTML-tree input-field))))
      
      (surflet-form 
-       ;; Must do something to prevent the callback-function string to
+       ;; Must do something to prevent the k-url string to be HTML
-       ;; be HTML escaped.
+       ;; escaped.
        *preorder*
-       . ,(lambda (trigger call-back-function . args)
+       . ,(lambda (trigger k-url . args)
 	    (receive (parameters elems)
 		(typed-optionals (list symbol? XML-attribute?) args)
-	      (make-surflet-form call-back-function 
+	      (make-surflet-form k-url ; k-url
-				 (car parameters)
+				 (car parameters) ; POST, GET or #f=GET
-				 (cadr parameters)
+				 (cadr parameters); attributes
-				 elems)))))
+				 elems))))) ; form-content
   ))
 
-(define (make-surflet-form call-back-function method attributes elems)
+(define (make-surflet-form k-url method attributes elems)
   (let ((real-method (case method
 		       ((get GET) "GET")
 		       ((post POST) "POST")
 		       ((#f) "GET")
 		       (else
 			(error "invalid method type" method)))))
-    `("<form" ,@(map (lambda (attribute-value)
+    (reformat 
-		       ((enattr (car attribute-value)) (cadr attribute-value)))
+     `(form (@ ((method ,real-method)
-		     `((method ,real-method)
+		(action ,k-url)
-		       (action ,call-back-function)
+		,@(if attributes (cdr attributes) '())))
-		       ;; We have to divide attributes explicitly.
+	    ,@elems))))
-		       ,@(if attributes (cdr attributes) '())))
-      #\> #\newline
-    ,(reformat elems)
-    "</form>")))
 
-(define (XML-attribute? thing)
+(define (xml-attribute? thing)
   (and (pair? thing)
        (eq? '@ (car thing))))
 
 (define attribute-rule
   `(@		; local override for attributes
     ((*default*       
-      . ,(lambda (attr-key . value) ((enattr attr-key) value))))
+      . ,(lambda (attr-key . value) (enattr attr-key value))))
     . ,(lambda (trigger . value) (list '@ value))))
 
+;; Create attribution-value pair for inside of tags
+;; If the attribute has no value, value must be '()
+(define (enattr attr-key attr-value)
+  (if (null? attr-value) 
+      (list #\space attr-key)
+      (list #\space attr-key "=\"" attr-value #\")))
+
 (define text-rule
   `(*text*
     . ,(lambda (trigger str) 
@@ -221,10 +222,12 @@
 
 (define URL-rule
   (cons 'URL 
-	(lambda (tag URI . maybe-text) (list "<a href=\"" URI "\">" 
+	(lambda (tag URI . maybe-text) 
-					     (if (pair? maybe-text)
+	  (list "<a href=\"" URI "\">" 
-						 maybe-text
+		(if (null? maybe-text)
-						 URI)"</a>"))))
+		    URI
+		    maybe-text)
+		"</a>"))))
 
 (define plain-html-rule
   `(plain-html
@@ -299,11 +302,12 @@
 	  (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
+;; whose first element is input-field-trigger and the last (next) one
-;; real input-field.
+;; is a real input-field.
+(define input-field-trigger '*input-field*)
 (define (input-field? input-field)
   (and (pair? input-field)
-       (eq? 'input-field (car input-field))
+       (eq? input-field-trigger (car input-field))
        (real-input-field? (cadr input-field))))
 
 ;; FIXME: consider creating small names
@@ -318,10 +322,10 @@
 
 ;; 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)))
+  (list input-field-trigger (real-make-input-field name transformer HTML-tree #f)))
 
 (define (make-higher-input-field transformer HTML-tree)
-  (list 'input-field (real-make-input-field #f transformer HTML-tree #t)))
+  (list input-field-trigger (real-make-input-field #f transformer HTML-tree #t)))
 
 ;; PRED-LIST contains list of predicates that recognizes optional
 ;; leading parameters. FURTHER-ATTRIBUTES is the optional parameter
@@ -333,7 +337,7 @@
 ;; like `make-submit-button [string] [further-attributes]' this way:
 ;; (define (make-submit-button . args)
 ;;   (receive (params rest-args) 
-;;     (prefix-optionals (list string? XML-attribute?) args)
+;;     (prefix-optionals (list string? xml-attribute?) args)
 ;;     (if (pair? rest-args)
 ;;         (error "too many arguments to make-submit-button))
 ;;         (let ((value (first params))
@@ -398,7 +402,7 @@
   (let ((name (generate-input-field-name "text")))
     (optionals maybe-further-attributes 
 	((default-text string?)
-	 (attributes XML-attribute?))
+	 (attributes xml-attribute?))
       (make-input-field name
 			identity
 			`(input (@ (type "text")
@@ -420,7 +424,7 @@
 	(optionals maybe-further-attributes
 	    ((default (lambda (a) (or (number? a)
 				      (string-or-symbol? a))))
-	     (attributes XML-attribute?))
+	     (attributes xml-attribute?))
 	  (make-input-field
 	   name
 	   number-input-field-transformer
@@ -432,7 +436,7 @@
 (define (make-password-input-field . maybe-further-attributes)
   (let ((name (generate-input-field-name "password")))
     (optionals maybe-further-attributes
-	((attributes XML-attribute?))
+	((attributes xml-attribute?))
       (make-input-field 
        name
        identity
@@ -444,7 +448,7 @@
   (let ((name (generate-input-field-name "textarea")))
     (optionals maybe-further-attributes
 	((default-text string?)
-	 (attributes XML-attribute?))
+	 (attributes xml-attribute?))
       (make-input-field 
        name
        identity
@@ -472,7 +476,7 @@
     (lambda (options . maybe-further-attributes)
       (optionals maybe-further-attributes
 	    ((multiple? boolean?)
-	     (attributes XML-attribute?))
+	     (attributes xml-attribute?))
 	(let* ((name (generate-input-field-name "select"))
 	       (SXML-options 
 		(map (lambda (option)
@@ -483,7 +487,7 @@
 			 (cond
 			  ((null? (cdr option))
 			   `(option ,option))
-			  ((XML-attribute? (cdr option)) ; w/attribs?
+			  ((xml-attribute? (cdr option)) ; w/attribs?
 			   `(option ,(cdr option) ,(car option)))
 			  (else
 			   (error "not an attribute" (cdr option)))))
@@ -503,11 +507,11 @@
 (define (make-radio-input-fields values . maybe-further-attributes)
   (let ((name (generate-input-field-name "radio")))
     (optionals maybe-further-attributes
-	((attributes XML-attribute?))
+	((attributes xml-attribute?))
       (map (lambda (value)
 	     (let ((value-value (if (pair? value) (car value) value))
 		   (value-attributes (if (pair? value)
-					 (if (XML-attribute? (cdr value))
+					 (if (xml-attribute? (cdr value))
 					     (cddr value)
 					     (error "not an attribute" cdr value))
 					 #f)))
@@ -530,7 +534,7 @@
 	 (value (lambda (a) (or (string? a) 
 				(number? a)
 				(symbol? a))))
-	 (attributes XML-attribute?))
+	 (attributes xml-attribute?))
       (make-input-field
        name
        (lambda (value)
@@ -546,7 +550,7 @@
 (define (make-hidden-input-field value . maybe-further-attributes)
   (let ((name (generate-input-field-name "hidden")))
     (optionals maybe-further-attributes
-	((attributes XML-attribute?))
+	((attributes xml-attribute?))
       (make-input-field name
 			identity
 			`(input (@ (type "hidden")
@@ -569,20 +573,20 @@
 (define (make-submit-button . maybe-further-attributes)
   (optionals maybe-further-attributes
       ((button-caption string-or-symbol?)
-       (attributes XML-attribute?))
+       (attributes xml-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 XML-attribute?))
+       (attributes xml-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 XML-attribute?))
+      ((attributes xml-attribute?))
     (make-button "image"  (generate-input-field-name "imgbtn")
 		 #f `(@ (src ,image-source) 
 			,@(if attributes (cdr attributes) '())))))