MAKE-SELECT-INPUT-FIELD can now create select input fields with multiple

selections. INPUT-FIELD-VALUE will always return a (possible empty) list in
the multiple case.
This commit is contained in:
interp 2002-10-04 13:56:46 +00:00
parent eef78201f0
commit 85b0d91475
3 changed files with 52 additions and 28 deletions

View File

@ -399,31 +399,44 @@
;; preselected option: (selected)
;; changed return value: (value new-value)
;; returns a select input field with several options
(define (make-select-input-field options . maybe-further-attributes)
(let ((name (generate-input-field-name "select")))
(define make-select-input-field
(let ((make-multiple-transformer
(lambda (name)
(lambda (bindings)
(map cdr
(filter (lambda (binding)
(equal? (car binding) name))
bindings))))))
(lambda (options . maybe-further-attributes)
(optionals maybe-further-attributes
((attributes XML-attribute?))
(make-input-field
name
identity ;FIXME[extension] refer to list elements
`(select (@ ((name ,name)
,(and attributes (cdr attributes))))
#\newline
,@(map (lambda (option)
((multiple? boolean?)
(attributes XML-attribute?))
(let* ((name (generate-input-field-name "select"))
(SXML-options
(map (lambda (option)
(cond
((string? option)
((string-or-symbol? option)
(list 'option option))
((list? option)
(cond
((null? (cdr option))
`(option ,option))
((XML-attribute? (cadr option)) ; with attributes?
((XML-attribute? (cadr option)) ; w/attribs?
`(option ,(cadr option) ,(car option)))
(else
(error "not an attribute" (cdr option)))))
(else
(error "not an option" option))))
options))))))
options))
(SXML `(select (@ ((name ,name)
,(if multiple? '(multiple) '())
,(and attributes (cdr attributes))))
#\newline
,SXML-options)))
(if multiple?
(make-upper-input-field (make-multiple-transformer name) SXML)
(make-input-field name identity SXML)))))))
;; returns a *list* of radio buttons
(define (make-radio-input-fields values . maybe-further-attributes)
@ -509,6 +522,8 @@
#f `(@ (src ,image-source)
,@(if attributes (cdr attributes) '())))))
;; <input-field>: '(input-field . <real-input-field>)
;; <real-input-field>: #{Input-field "name"}
(define (input-field-value input-field bindings)
(let ((input-field (cadr input-field)))
(cond

View File

@ -51,9 +51,6 @@
,(make-submit-button "Do it")))
,footer)))))
(bindings (get-bindings req))
;; No error handling as always something is selected. If
;; not, the browser did something wrong and we may yield
;; an error anyway.
(action (input-field-value select bindings)))
(if (string=? action action-title)

View File

@ -4,6 +4,18 @@
servlets
httpd-responses)
(begin
(define select (make-select-input-field '("a" "b" "c") #t '(@ (size 2))))
(define (main req)
(let ((req (send-html/suspend
(lambda (new-url)
`(html (body (h1 "This is from servlet")
(servlet-form
,new-url
,select
,(make-submit-button))
))))))
(send-html/finish
'(html (body (h1 "This is from servlet")))))))
`(html (body (h1 "Result")
,(format #f "~s" (get-bindings req)))))))
))