diff --git a/scheme/httpd/surflets/surflets.scm b/scheme/httpd/surflets/surflets.scm index 2345247..aa2bc48 100644 --- a/scheme/httpd/surflets/surflets.scm +++ b/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) - (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) +(define (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) - (formated-reply out - (reformat html-tree))) +(define (surflet-xml->html port html-tree) + (let ((fragments (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 - ;; be HTML escaped. + ;; Must do something to prevent the k-url string to be HTML + ;; 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 - (car parameters) - (cadr parameters) - elems))))) + (make-surflet-form k-url ; k-url + (car parameters) ; POST, GET or #f=GET + (cadr parameters); attributes + 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))))) - `(" #\newline - ,(reformat elems) - ""))) + (reformat + `(form (@ ((method ,real-method) + (action ,k-url) + ,@(if attributes (cdr attributes) '()))) + ,@elems)))) -(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 "" - (if (pair? maybe-text) - maybe-text - URI)"")))) + (lambda (tag URI . maybe-text) + (list "" + (if (null? maybe-text) + URI + maybe-text) + "")))) (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 -;; real input-field. +;; whose first element is input-field-trigger and the last (next) one +;; 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) '())))))