275 lines
9.0 KiB
Scheme
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))
|
|
|