+ (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
parent
2e5f385410
commit
78a1d2e633
|
|
@ -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.
|
||||
(reformat
|
||||
`(form (@ ((method ,real-method)
|
||||
(action ,k-url)
|
||||
,@(if attributes (cdr attributes) '())))
|
||||
#\> #\newline
|
||||
,(reformat elems)
|
||||
"</form>")))
|
||||
,@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) '())))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue