diff --git a/scheme/httpd/surflets/surflets.scm b/scheme/httpd/surflets/surflets.scm index cd0bd3a..117d2f6 100644 --- a/scheme/httpd/surflets/surflets.scm +++ b/scheme/httpd/surflets/surflets.scm @@ -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"))) - (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) +(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 + ((multiple? boolean?) + (attributes XML-attribute?)) + (let* ((name (generate-input-field-name "select")) + (SXML-options + (map (lambda (option) + (cond + ((string-or-symbol? option) + (list 'option option)) + ((list? option) (cond - ((string? option) - (list 'option option)) - ((list? option) - (cond - ((null? (cdr option)) - `(option ,option)) - ((XML-attribute? (cadr option)) ; with attributes? - `(option ,(cadr option) ,(car option))) - (else - (error "not an attribute" (cdr option))))) + ((null? (cdr option)) + `(option ,option)) + ((XML-attribute? (cadr option)) ; w/attribs? + `(option ,(cadr option) ,(car option))) (else - (error "not an option" option)))) - options)))))) + (error "not an attribute" (cdr option))))) + (else + (error "not an option" option)))) + 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 "name"} (define (input-field-value input-field bindings) (let ((input-field (cadr input-field))) (cond diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm index e758fa9..18c3481 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm @@ -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) diff --git a/scheme/httpd/surflets/web-server/root/surflets/test.scm b/scheme/httpd/surflets/web-server/root/surflets/test.scm index da54324..81e28ea 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/test.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/test.scm @@ -4,6 +4,18 @@ servlets httpd-responses) (begin + (define select (make-select-input-field '("a" "b" "c") #t '(@ (size 2)))) + (define (main req) - (send-html/finish - '(html (body (h1 "This is from servlet"))))))) + (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 "Result") + ,(format #f "~s" (get-bindings req))))))) + ))