531 lines
19 KiB
Scheme
531 lines
19 KiB
Scheme
;;; SUrflets' input fields
|
|
;;; Copyright 2002, 2003 Andreas Bernauer
|
|
;;; With additions from Eric Knauel (2003)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Functions to create simple input fields
|
|
|
|
;; The interface for input-fields does not prescribe what the type of
|
|
;; attributes has to be. We choose a record here.
|
|
|
|
(define-record-type input-field-attributes :input-field-attributes
|
|
(make-input-field-attributes default others)
|
|
input-field-attributes?
|
|
(default input-field-attributes-default set-input-field-attributes-default!)
|
|
(others input-field-attributes-others set-input-field-attributes-others!))
|
|
|
|
;; A simple input-field is a prototype for other input-fields.
|
|
;; REPORTED-TYPE is the type of the input-field in HTML, TYPE the
|
|
;; internal referenced type and TRANSFORMER the function that
|
|
;; translates the HTTP-string of the request into a scheme value.
|
|
(define (simple-input-field-maker reported-type type default-pred transformer)
|
|
(lambda maybe-further-attributes
|
|
(let ((name (generate-input-field-name type)))
|
|
(optionals maybe-further-attributes
|
|
((default default-pred)
|
|
(attributes sxml-attribute?))
|
|
(make-input-field name type
|
|
transformer
|
|
(make-input-field-attributes
|
|
(and default `(value ,default))
|
|
(sxml-attribute-attributes attributes))
|
|
(simple-input-field-maker-html-tree-maker
|
|
reported-type))))))
|
|
|
|
(define (simple-input-field-maker-html-tree-maker reported-type)
|
|
(lambda (input-field)
|
|
(let ((attributes (input-field-attributes input-field)))
|
|
`(input (@ (type ,reported-type)
|
|
(name ,(input-field-name input-field))
|
|
,(input-field-attributes-default attributes)
|
|
,(input-field-attributes-others attributes))))))
|
|
|
|
(define (make-simple-input-field-default-setter default-pred? wrap?)
|
|
(lambda (input-field value)
|
|
(if (default-pred? value)
|
|
(set-input-field-attributes-default!
|
|
(input-field-attributes input-field)
|
|
(if wrap? `(value ,value) value))
|
|
(error "Default value must be a number or a string or a symbol."
|
|
value))
|
|
(touch-input-field! input-field)))
|
|
|
|
(define (string-or-symbol? thing)
|
|
(or (string? thing) (symbol? thing)))
|
|
(define simple-default? string-or-symbol?)
|
|
|
|
(define set-simple-input-field-default!
|
|
(make-simple-input-field-default-setter simple-default? #t))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;
|
|
;;; Text input field
|
|
(define make-text-input-field
|
|
(simple-input-field-maker "text" "text"
|
|
simple-default? identity))
|
|
(define set-text-input-field-value! set-simple-input-field-default!)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Number input field
|
|
(define (number-input-field-default? value)
|
|
(or (number? value)
|
|
(simple-default? value)))
|
|
(define (number-input-field-transformer string)
|
|
(or (string->number string)
|
|
(error "wrong type")))
|
|
(define make-number-input-field
|
|
(simple-input-field-maker "text" "number"
|
|
number-input-field-default?
|
|
number-input-field-transformer))
|
|
(define set-number-input-field-value!
|
|
(make-simple-input-field-default-setter number-input-field-default? #t))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; hidden input-field
|
|
;; Little workaraound, as a hidden input-field needs a value. This
|
|
;; value is propagated in the slot "default value".
|
|
(define make-hidden-input-field
|
|
(let ((hidden-input-field-generator
|
|
(simple-input-field-maker "hidden" "text"
|
|
simple-default? identity)))
|
|
(lambda (value . maybe-further-attributes)
|
|
(apply hidden-input-field-generator
|
|
(cons value maybe-further-attributes)))))
|
|
(define set-hidden-input-field-value!
|
|
set-simple-input-field-default!)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Password input field
|
|
(define make-password-input-field
|
|
(simple-input-field-maker "password" "password"
|
|
simple-default? identity))
|
|
(define set-password-input-field-value!
|
|
set-simple-input-field-default!)
|
|
|
|
;;; That's it for simple input fields.
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Textarea input field
|
|
(define (make-textarea-input-field . maybe-further-attributes)
|
|
(let ((name (generate-input-field-name "textarea")))
|
|
(optionals maybe-further-attributes
|
|
((default-text simple-default?)
|
|
(rows number?)
|
|
(cols number?)
|
|
(readonly symbol?)
|
|
(attributes sxml-attribute?))
|
|
(let ((extra-attributes '()))
|
|
(if (eq? readonly 'readonly)
|
|
(set! extra-attributes (cons '(readonly) extra-attributes)))
|
|
(if cols (set! extra-attributes (cons `(cols ,cols) extra-attributes)))
|
|
(if rows (set! extra-attributes (cons `(rows ,rows) extra-attributes)))
|
|
(make-input-field
|
|
name "textarea"
|
|
identity
|
|
(make-input-field-attributes
|
|
(and default-text)
|
|
(cons extra-attributes (sxml-attribute-attributes attributes)))
|
|
make-textarea-input-field-html-tree)))))
|
|
|
|
(define (make-textarea-input-field-html-tree input-field)
|
|
(let ((attributes (input-field-attributes input-field)))
|
|
`(textarea (@ (type "textarea")
|
|
(name ,(input-field-name input-field))
|
|
,(input-field-attributes-others attributes))
|
|
,(input-field-attributes-default attributes))))
|
|
|
|
(define set-textarea-input-field-value!
|
|
(let ((textarea-default-setter!
|
|
(make-simple-input-field-default-setter simple-default? #f)))
|
|
(lambda (textarea-input-field value)
|
|
(textarea-default-setter! textarea-input-field value))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Selection input field
|
|
|
|
;; sel-if == select-input-field
|
|
;(make-select-input-fields '("this" "that" "those") '(@ ((id "sushi"))))
|
|
;(make-select-input-fields '("this" ("that" '(@ (selected))) "those"))
|
|
;; dropdown: (size 1)
|
|
|
|
;;; A selection input field shows a list of options that can be
|
|
;;; selected. For this purpose, we introduce an sel-if-option record,
|
|
;;; that contains all the information for each option. This is
|
|
;;; justified by the fact, that the options list is seperated in HTML,
|
|
;;; too. The TAG is the string that is displayed in the website, the
|
|
;;; VALUE is the value that is returned by input-field-value, if this
|
|
;;; option was selected. TAG is assumed to be unique by some functions
|
|
;;; (e.g. select and unselect) SELECTED? tells us, if this option is
|
|
;;; preselected.
|
|
(define-record-type sel-if-option :sel-if-option
|
|
(really-make-sel-if-option tag value selected? attributes)
|
|
sel-if-option?
|
|
(tag sel-if-option-tag)
|
|
(value sel-if-option-value)
|
|
(selected? sel-if-option-selected? set-sel-if-option-selected?!)
|
|
(attributes sel-if-option-attributes set-sel-if-option-attributes!))
|
|
|
|
(define (make-sel-if-option tag value selected? attributes)
|
|
(if (string? tag)
|
|
(really-make-sel-if-option tag value selected?
|
|
(sxml-attribute-attributes attributes))
|
|
(error "Select-input-field-option's tag must be a string." tag)))
|
|
|
|
;; Constructor for valued select input-field option.
|
|
(define (make-annotated-sel-if-option tag value . maybe-attributes)
|
|
(optionals maybe-attributes
|
|
((selected? boolean?)
|
|
(attributes sxml-attribute?))
|
|
(make-sel-if-option tag value selected? attributes)))
|
|
|
|
;; Constructor for a simple select input-field option (not annotated).
|
|
(define (make-simple-sel-if-option tag . maybe-attributes)
|
|
(optionals maybe-attributes
|
|
((selected? boolean?)
|
|
(attributes sxml-attribute?))
|
|
(make-sel-if-option tag tag selected? attributes)))
|
|
|
|
(define-record-discloser :sel-if-option
|
|
(lambda (sel-if-option)
|
|
(list 'select-input-field-option
|
|
(sel-if-option-tag sel-if-option)
|
|
(sel-if-option-value sel-if-option)
|
|
(sel-if-option-selected? sel-if-option)
|
|
(sel-if-option-attributes sel-if-option)
|
|
)))
|
|
|
|
;; Selecting / Unselecting of an option in an select input-field,
|
|
;; chosen by tag.
|
|
(define (select-sel-if-option! tag sel-if)
|
|
(set-select-input-field-option-selected?! tag sel-if #t))
|
|
|
|
(define (unselect-sel-if-option! tag sel-if)
|
|
(set-select-input-field-option-selected?! tag sel-if #f))
|
|
|
|
(define (set-select-input-field-option-selected?! tag sel-if selected?)
|
|
(let ((options (input-field-attributes-default
|
|
(input-field-attributes sel-if))))
|
|
(if (number? tag) ; is tag an index?
|
|
(set-sel-if-option-selected?! (list-ref options tag)
|
|
selected?)
|
|
(let lp ((options options))
|
|
(if (null? options)
|
|
(error "No such option" tag sel-if)
|
|
(if (tag=sel-if-option? tag (car options))
|
|
(set-sel-if-option-selected?! (car options) selected?)
|
|
(lp (cdr options))))))
|
|
(touch-input-field! sel-if)))
|
|
|
|
;; Find sel-if-option in a list by its tag.
|
|
(define (tag=sel-if-option? tag sel-if-option)
|
|
(string=? tag (sel-if-option-tag sel-if-option)))
|
|
|
|
(define (find-sel-if-option tag sel-if-options)
|
|
(cond ((member/srfi-1 tag sel-if-options tag=sel-if-option?)
|
|
=> car)
|
|
;; MEMBER/SRFI-1 returns the sublist that starts with the
|
|
;; searched element.
|
|
(else #f)))
|
|
|
|
(define (find-sel-if-option-value tag sel-if-options)
|
|
(cond ((find-sel-if-option tag sel-if-options)
|
|
=> sel-if-option-value)
|
|
(else #f)))
|
|
|
|
(define (add-sel-if-option! sel-if sel-if-option)
|
|
(let ((attributes (input-field-attributes sel-if)))
|
|
(set-input-field-attributes-default!
|
|
attributes
|
|
(cons sel-if-option
|
|
(input-field-attributes-default attributes)))
|
|
(touch-input-field! sel-if)))
|
|
|
|
(define (delete-sel-if-option! sel-if sel-if-option)
|
|
(let* ((attributes (input-field-attributes sel-if))
|
|
(sel-if-options (input-field-attributes-default attributes)))
|
|
(if (sel-if-option? sel-if-option)
|
|
(set-input-field-attributes-default!
|
|
attributes
|
|
(delete sel-if-option sel-if-options))
|
|
(let ((tag sel-if-option))
|
|
(set-input-field-attributes-default!
|
|
attributes
|
|
(delete tag sel-if-options tag=sel-if-option?))))
|
|
(touch-input-field! sel-if)))
|
|
|
|
;; To be compatible with previous versions of MAKE-SELECT-INPUT-FIELD,
|
|
;; we accept also a simple list as an option-list. New programs should
|
|
;; use sel-if-options-list (easily createable with
|
|
;; (map make-simple-sel-if-option option-list))
|
|
(define (tolerate-old-sel-if-options sel-if-options)
|
|
(if (and (list? sel-if-options)
|
|
(every sel-if-option? sel-if-options))
|
|
sel-if-options
|
|
(map make-simple-sel-if-option sel-if-options)))
|
|
|
|
(define (make-select-input-field sel-if-options . maybe-further-attributes)
|
|
(really-make-select-input-field (tolerate-old-sel-if-options sel-if-options)
|
|
maybe-further-attributes))
|
|
|
|
(define (make-annotated-select-input-field sel-if-options .
|
|
maybe-further-attributes)
|
|
(really-make-select-input-field sel-if-options maybe-further-attributes))
|
|
|
|
(define (really-make-select-input-field sel-if-options
|
|
maybe-further-attributes)
|
|
(let ((real-sel-if-options (tolerate-old-sel-if-options sel-if-options)))
|
|
(optionals maybe-further-attributes
|
|
((multiple? boolean?)
|
|
(attributes sxml-attribute?))
|
|
(let ((name (generate-input-field-name "select")))
|
|
(if multiple?
|
|
(make-multiple-select-input-field name sel-if-options attributes)
|
|
(make-single-select-input-field name sel-if-options
|
|
attributes))))))
|
|
|
|
;; internal
|
|
(define (make-multiple-select-input-field name sel-if-options attributes)
|
|
(make-multi-input-field name "mult-select"
|
|
sel-if-multiple-transformer
|
|
(make-input-field-attributes
|
|
sel-if-options
|
|
(list '(multiple)
|
|
(sxml-attribute-attributes attributes)))
|
|
make-sel-if-html-tree))
|
|
|
|
;; internal
|
|
(define (make-single-select-input-field name sel-if-options attributes)
|
|
(make-input-field name "select"
|
|
(lambda (tag)
|
|
(cond ((find-sel-if-option-value tag sel-if-options)
|
|
=> identity)
|
|
(else (error "no such option." tag))))
|
|
(make-input-field-attributes
|
|
sel-if-options
|
|
(sxml-attribute-attributes attributes))
|
|
make-sel-if-html-tree))
|
|
|
|
(define (sel-if-multiple-transformer input-field bindings)
|
|
(let ((name (input-field-name input-field))
|
|
(sel-if-options (input-field-attributes-default
|
|
(input-field-attributes input-field))))
|
|
(let* ((my-bindings (filter (lambda (binding)
|
|
(equal? (car binding) name))
|
|
bindings))
|
|
(tags (map cdr my-bindings)))
|
|
(filter-map (lambda (tag)
|
|
(find-sel-if-option-value tag sel-if-options))
|
|
tags))))
|
|
|
|
(define (make-sel-if-html-tree sel-if)
|
|
(let ((attributes (input-field-attributes sel-if)))
|
|
`(select (@ (name ,(input-field-name sel-if))
|
|
,(input-field-attributes-others attributes))
|
|
#\newline
|
|
,@(make-sel-if-options-html-tree
|
|
(input-field-attributes-default attributes)))))
|
|
|
|
(define (make-sel-if-options-html-tree sel-if-options)
|
|
(map (lambda (sel-if-option)
|
|
`(option (@ ,(and (sel-if-option-selected? sel-if-option) '(selected))
|
|
,(sel-if-option-attributes sel-if-option))
|
|
,(sel-if-option-tag sel-if-option)))
|
|
sel-if-options))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; radio input-fields
|
|
;; Because grouped radio input-fields must use the same name, we
|
|
;; cannot just return one radio input-field object, but we must
|
|
;; generate several ones with the same name.
|
|
(define (make-radio-input-field-group)
|
|
(let ((name (generate-input-field-name "radio")))
|
|
(lambda (value-string . maybe-further-attributes)
|
|
(optionals maybe-further-attributes
|
|
((checked? boolean?)
|
|
(attributes sxml-attribute?))
|
|
(make-input-field name "radio"
|
|
identity
|
|
(make-input-field-attributes
|
|
(if checked? '(checked) #f)
|
|
(list `(value ,value-string)
|
|
(sxml-attribute-attributes attributes)))
|
|
radio-input-field-html-tree-maker)))))
|
|
|
|
(define (make-annotated-radio-input-field-group)
|
|
(let* ((name (generate-input-field-name "radio"))
|
|
(value-table (make-integer-table))
|
|
(transformer (make-radio-input-field-transformer value-table)))
|
|
(lambda (value . maybe-further-attributes)
|
|
(optionals maybe-further-attributes
|
|
((checked? boolean?)
|
|
(attributes sxml-attribute?))
|
|
(let ((number (generate-unique-number)))
|
|
(table-set! value-table number value)
|
|
(make-input-field name "radio"
|
|
transformer
|
|
(make-input-field-attributes
|
|
(if checked? '(checked) #f)
|
|
(list`(value ,(number->string number))
|
|
(sxml-attribute-attributes attributes)))
|
|
radio-input-field-html-tree-maker))))))
|
|
|
|
(define (make-radio-input-fields values . maybe-further-attributes)
|
|
(optionals maybe-further-attributes
|
|
((attributes sxml-attribute?))
|
|
(let ((radio-gen (make-annotated-radio-input-field-group)))
|
|
(map (lambda (value)
|
|
(if attributes
|
|
(radio-gen value attributes)
|
|
(radio-gen value)))
|
|
values))))
|
|
|
|
|
|
(define (make-radio-input-field-transformer value-table)
|
|
(lambda (tag)
|
|
(cond
|
|
((string->number tag) =>
|
|
(lambda (number)
|
|
(let ((value (table-ref value-table number)))
|
|
(if value
|
|
value
|
|
(error "Unknown tag number for radio input-field" tag)))))
|
|
(else
|
|
(error "Unknown tag number for radio input-field" tag)))))
|
|
|
|
(define (radio-input-field-html-tree-maker radio-input-field)
|
|
(let* ((attributes (input-field-attributes radio-input-field)))
|
|
`(input (@ ((type "radio")
|
|
(name ,(input-field-name radio-input-field))
|
|
,(input-field-attributes-default attributes)
|
|
,(input-field-attributes-others attributes))))))
|
|
|
|
(define (set-input-field-checked?! input-field checked?)
|
|
(let ((attributes (input-field-attributes input-field)))
|
|
(set-input-field-attributes-default!
|
|
attributes
|
|
(if checked? '(checked) #f))
|
|
(touch-input-field! input-field)))
|
|
|
|
(define set-radio-input-field-checked?! set-input-field-checked?!)
|
|
(define (check-radio-input-field! radio)
|
|
(set-radio-input-field-checked?! radio #t))
|
|
(define (uncheck-radio-input-field! radio)
|
|
(set-radio-input-field-checked?! radio #f))
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; checkbox input-field
|
|
(define (make-checkbox-input-field . maybe-further-attributes)
|
|
(really-make-checkbox-input-field #t
|
|
checkbox-transformer
|
|
maybe-further-attributes))
|
|
|
|
(define (make-annotated-checkbox-input-field value . maybe-further-attributes)
|
|
(really-make-checkbox-input-field value
|
|
(make-checkbox-transformer value)
|
|
maybe-further-attributes))
|
|
|
|
(define (really-make-checkbox-input-field value transformer attributes)
|
|
(let ((name (generate-input-field-name "checkbox")))
|
|
(optionals attributes
|
|
((checked? boolean?)
|
|
(attributes sxml-attribute?))
|
|
(make-input-field name "checkbox"
|
|
transformer
|
|
(make-input-field-attributes
|
|
(if checked? '(checked) #f)
|
|
(sxml-attribute-attributes attributes))
|
|
checkbox-input-field-html-tree-maker))))
|
|
|
|
(define (make-checkbox-transformer value)
|
|
(lambda (tag)
|
|
(if (string=? tag "on")
|
|
value
|
|
#f)))
|
|
|
|
(define checkbox-transformer
|
|
(make-checkbox-transformer #t))
|
|
|
|
(define (checkbox-input-field-html-tree-maker cb-if)
|
|
(let ((attributes (input-field-attributes cb-if)))
|
|
`(input (@ ((type "checkbox")
|
|
(name ,(input-field-name cb-if))
|
|
,(input-field-attributes-default attributes)
|
|
,(input-field-attributes-others attributes))))))
|
|
|
|
(define set-checkbox-input-field-checked?! set-input-field-checked?!)
|
|
(define (check-checkbox-input-field! checkbox)
|
|
(set-checkbox-input-field-checked?! checkbox #t))
|
|
(define (uncheck-checkbox-input-field! checkbox)
|
|
(set-checkbox-input-field-checked?! checkbox #f))
|
|
;;;;;;;;;;;;;;;;;;;;;;
|
|
;; button input-fields
|
|
(define (make-button type name button-caption attributes)
|
|
(make-input-field name type
|
|
identity
|
|
(make-input-field-attributes
|
|
(and button-caption `(value ,button-caption))
|
|
(sxml-attribute-attributes attributes))
|
|
make-button-html-tree))
|
|
|
|
(define (make-button-html-tree button-input-field)
|
|
(let ((attributes (input-field-attributes button-input-field)))
|
|
`(input (@ (type ,(input-field-type button-input-field))
|
|
(name ,(input-field-name button-input-field))
|
|
,(input-field-attributes-default attributes)
|
|
,(input-field-attributes-others attributes)))))
|
|
|
|
(define (make-submit-button . maybe-further-attributes)
|
|
(optionals maybe-further-attributes
|
|
((button-caption string?)
|
|
(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?)
|
|
(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)
|
|
,@(sxml-attribute-attributes attributes)))))
|
|
|
|
;; Image buttons cannot be simple buttons, as the browser does not
|
|
;; send their simple name, but the coordinates where the user clicked
|
|
;; into. Thanks to Eric Knauel for reporting this bug.
|
|
(define (make-image-button image-source . maybe-further-attributes)
|
|
(optionals maybe-further-attributes
|
|
((attributes sxml-attribute?))
|
|
(make-multi-input-field (generate-input-field-name "imgbtn")
|
|
"image"
|
|
image-button-transformer
|
|
(make-input-field-attributes
|
|
`(src ,image-source)
|
|
(sxml-attribute-attributes attributes))
|
|
make-button-html-tree)))
|
|
|
|
;; The following two functions are from Eric Knauel's fix for the
|
|
;; image-button bug:
|
|
(define (image-button-transformer image-button bindings)
|
|
(let ((x (find-image-button-coordinate image-button bindings ".x"))
|
|
(y (find-image-button-coordinate image-button bindings ".y")))
|
|
(let ((x-number (string->number x))
|
|
(y-number (string->number y)))
|
|
(and x y
|
|
(if (and x-number y-number)
|
|
(cons x-number y-number)
|
|
(error "Image button coordinates aren't numbers. " x y))))))
|
|
|
|
(define (find-image-button-coordinate image-button bindings suffix)
|
|
(let* ((name (input-field-name image-button)))
|
|
(cond
|
|
((assoc (string-append name suffix) bindings)
|
|
=> (lambda (pair)
|
|
(cdr pair)))
|
|
(else #f))))
|
|
|
|
|
|
;;EOF |