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

SERVLET-FORM accepts a method specifier: 

SERVLET-FORM return-address [method] [attributes] [elements]
This commit is contained in:
interp 2002-10-04 14:31:28 +00:00
parent a6b499426a
commit 7b81dbdd98
1 changed files with 22 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -136,22 +136,31 @@
;; Must do something to prevent the callback-function string to ;; Must do something to prevent the callback-function string to
;; be HTML escaped. ;; be HTML escaped.
*preorder* *preorder*
. ,(lambda (trigger call-back-function . elems) . ,(lambda (trigger call-back-function . args)
(if (and (pair? elems) (receive (parameters elems)
(XML-attribute? (car elems))) (typed-optionals (list symbol? XML-attribute?) args)
(make-servlet-form call-back-function (cdar elems) (cdr elems)) (make-servlet-form call-back-function
(make-servlet-form call-back-function'() elems))))) (car parameters)
(cadr parameters)
elems)))))
)) ))
(define (make-servlet-form call-back-function attributes elems) (define (make-servlet-form call-back-function method attributes elems)
`("<form" ,@(map (lambda (attribute-value) (let ((real-method (case method
((enattr (car attribute-value)) (cadr attribute-value))) ((get GET) "GET")
`((method "POST") ((post POST) "POST")
(action ,call-back-function) ((#f) "GET")
,@attributes)) (else
#\> #\newline (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) ,(reformat elems)
"</form>")) "</form>")))
(define (XML-attribute? thing) (define (XML-attribute? thing)
(and (pair? thing) (and (pair? thing)