scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

+ 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
This commit is contained in:
interp 2002-09-27 15:24:44 +00:00
parent 9c6db22736
commit 99fb8f3e32
1 changed files with 134 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

214
scheme/httpd/surflets/surflets.scm
View File

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