+ (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.
This commit is contained in:
interp 2003-03-07 18:34:04 +00:00
parent 2e5f385410
commit 78a1d2e633
1 changed files with 66 additions and 62 deletions

View File

@ -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)))))
`("<form" ,@(map (lambda (attribute-value)
((enattr (car attribute-value)) (cadr attribute-value)))
`((method ,real-method)
(action ,call-back-function)
;; We have to divide attributes explicitly.
,@(if attributes (cdr attributes) '())))
#\> #\newline
,(reformat elems)
"</form>")))
(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 "<a href=\"" URI "\">"
(if (pair? maybe-text)
maybe-text
URI)"</a>"))))
(lambda (tag URI . maybe-text)
(list "<a href=\"" URI "\">"
(if (null? maybe-text)
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
;; 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) '())))))