sunet/scheme/httpd/surflets/input-fields.scm

275 lines
9.0 KiB
Scheme

;;; Copyright 2002, 2003 Andreas Bernauer
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; input-fields
;;; defines input-fields for surflets
(define *input-field-trigger* `*input-field*)
;; GET-BINDINGS?: Transformer will get all bindings of request, not
;; only the one concerning the input-field.
(define-record-type input-field :input-field
(real-make-input-field name transformer html-tree get-bindings?)
real-input-field?
(name input-field-name)
(transformer input-field-transformer)
(attributes input-field-attributes)
(html-tree input-field-html-tree)
(get-bindings? input-field-get-bindings?))
(define-record-discloser :input-field
(lambda (input-field)
(list 'input-field
(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-trigger* and the last (next) one
;; is a real input-field.
(define (input-field? input-field)
(and (pair? input-field)
(eq? *input-field-trigger* (car input-field))
(real-input-field? (cadr input-field))))
(define generate-input-field-name generate-unique-name)
(define identity (lambda (a) a))
;; See note at input-field? for reasons for the list.
(define (make-input-field name transformer html-tree)
(list *input-field-trigger*
(real-make-input-field name transformer html-tree #f)))
(define (make-higher-input-field transformer html-tree)
(list *input-field-trigger*
(real-make-input-field #f transformer html-tree #t)))
(define (make-text-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "text")))
(optionals maybe-further-attributes
((default-text string?)
(attributes sxml-attribute?))
(make-input-field name
identity
`(input (@ (type "text")
(name ,name)
,(and default-text `(value ,default-text))
;; this will insert a list, but
;; XML->HTML doesn't care about it
,(and attributes (cdr attributes))
))))))
(define make-number-input-field
(let ((number-input-field-transformer
(lambda (string)
(or (string->number string)
(error "wrong type")))
))
(lambda maybe-further-attributes
(let ((name (generate-input-field-name "number")))
(optionals maybe-further-attributes
((default (lambda (a) (or (number? a)
(string-or-symbol? a))))
(attributes sxml-attribute?))
(make-input-field
name
number-input-field-transformer
`(input (@ (type "text")
(name ,name)
,(and default `(value ,default))
,(and attributes (cdr attributes))))))))))
(define (make-password-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "password")))
(optionals maybe-further-attributes
((attributes sxml-attribute?))
(make-input-field
name
identity
`(input (@ (type "password")
(name ,name)
,(and attributes (cdr attributes))))))))
(define (make-textarea-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "textarea")))
(optionals maybe-further-attributes
((default-text string?)
(attributes sxml-attribute?))
(make-input-field
name
identity
`(textarea (@ (type "textarea")
(name ,name)
,(and attributes (cdr attributes)))
,(and default-text))))))
;(make-select-input-fields '("this" "that" "those") '(@ ((id "sushi"))))
;(make-select-input-fields '("this" ("that" '(@ (selected))) "those"))
;; dropdown: (size 1)
;; multiple choice: (multiple)
;; preselected option: (selected)
;; changed return value: (value new-value)
;; returns a select input field with several options
(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 sxml-attribute?))
(let* ((name (generate-input-field-name "select"))
(sxml-options
(map (lambda (option)
(cond
((string-or-symbol? option)
(list 'option option))
((list? option)
(cond
((null? (cdr option))
`(option ,option))
((sxml-attribute? (cdr option)) ; w/attribs?
`(option ,(cdr option) ,(car option)))
(else
(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-higher-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)
(let ((name (generate-input-field-name "radio")))
(optionals maybe-further-attributes
((attributes sxml-attribute?))
(map (lambda (value)
(let ((value-value (if (pair? value) (car value) value))
(value-attributes (if (pair? value)
(if (sxml-attribute? (cdr value))
(cddr value)
(error "not an attribute" cdr value))
#f)))
(make-input-field
name
(lambda (select)
select)
`(input (@ ((type "radio")
(name ,name)
(value ,value-value)
,(and value-attributes)
,(and attributes (cdr attributes))))))))
values))))
;; returns a checkbox input field
(define (make-checkbox-input-field . maybe-further-attributes)
(let* ((name (generate-input-field-name "checkbox")))
(optionals maybe-further-attributes
((checked? boolean?)
(value (lambda (a) (or (string? a)
(number? a)
(symbol? a))))
(attributes sxml-attribute?))
(make-input-field
name
(lambda (value)
(or (string=? value "on")
value))
`(input (@ ((type "checkbox")
(name ,name)
,(if value `(value ,value) '())
,(if checked? '(checked) '())
,(and attributes (cdr attributes)))))))))
(define (make-hidden-input-field value . maybe-further-attributes)
(let ((name (generate-input-field-name "hidden")))
(optionals maybe-further-attributes
((attributes sxml-attribute?))
(make-input-field name
identity
`(input (@ (type "hidden")
(name ,name)
(value ,value)
,(and attributes (cdr attributes))))))))
(define (make-button type name button-caption attributes)
(make-input-field name
identity
`(input (@ (type ,type)
(name ,name)
,(and button-caption `(value ,button-caption))
,(and attributes (cdr attributes))))))
(define (string-or-symbol? a)
(or (string? a)
(symbol? a)))
(define (make-submit-button . maybe-further-attributes)
(optionals maybe-further-attributes
((button-caption string-or-symbol?)
(attributes sxml-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 sxml-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 sxml-attribute?))
(make-button "image" (generate-input-field-name "imgbtn")
#f `(@ (src ,image-source)
,@(if attributes (cdr attributes) '())))))
;; <input-field>: '(input-field . <real-input-field>)
;; <real-input-field>: #{Input-field "name"}
(define (raw-input-field-value input-field bindings)
(let ((input-field (cadr input-field)))
(cond
((input-field-get-bindings? input-field)
((input-field-transformer input-field) bindings))
((real-input-field-binding input-field bindings) =>
(lambda (binding)
((input-field-transformer input-field) (cdr binding))))
(else
(error "no such input-field" input-field bindings)))))
;; Trys to get a value for INPUT-FIELD in BINDINGS. If this fails
;; (i.e. RAW-INPUT-FIELD-VALUE returns an error), the default-value is
;; returned. The default-value defaults to #f. NOTE: If you do this
;; with input-fields whose valid values may be the same as the default
;; value, you cannot determine by the result if there was such a value
;; or not. Keep in mind, that RAW-INPUT-FIELD-VALUE returns also an
;; error, if there was not such an input field. This makes
;; INPUT-FIELD-VALUE working with checkbox input fields because they
;; miss if they are not checked.
(define (input-field-value input-field bindings . maybe-default)
(let ((default (:optional maybe-default #f)))
(with-fatal-error-handler
(lambda (condition more)
default)
(raw-input-field-value input-field bindings))))
(define (real-input-field-binding input-field bindings)
(assoc (input-field-name input-field) bindings))
(define (input-field-binding input-field bindings)
(real-input-field-binding (cadr input-field) bindings))