522 lines
18 KiB
Scheme
522 lines
18 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 field-attributes :field-attributes
|
|
(make-field-attributes default others)
|
|
field-attributes?
|
|
(default field-attributes-default set-field-attributes-default!)
|
|
(others field-attributes-others set-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-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-field-attributes
|
|
(and default `(value ,default))
|
|
(sxml-attribute-attributes attributes))
|
|
(simple-html-tree-maker reported-type))))))
|
|
|
|
(define (simple-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))
|
|
,(field-attributes-default attributes)
|
|
,(field-attributes-others attributes))))))
|
|
|
|
(define (make-simple-default-setter default-pred? wrap?)
|
|
(lambda (input-field value)
|
|
(if (default-pred? value)
|
|
(set-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-field-default!
|
|
(make-simple-default-setter simple-default? #t))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;
|
|
;;; Text input field
|
|
(define make-text-field
|
|
(simple-field-maker "text" "text" simple-default? identity))
|
|
(define set-text-field-value! set-simple-field-default!)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Number input field
|
|
(define (number-field-default? value)
|
|
(or (number? value)
|
|
(simple-default? value)))
|
|
(define (number-field-transformer string)
|
|
(or (string->number string)
|
|
(error "wrong type")))
|
|
(define make-number-field
|
|
(simple-field-maker "text" "number"
|
|
number-field-default? number-field-transformer))
|
|
(define set-number-field-value!
|
|
(make-simple-default-setter number-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-field
|
|
(let ((hidden-field-generator
|
|
(simple-field-maker "hidden" "text"
|
|
simple-default? identity)))
|
|
(lambda (value . maybe-further-attributes)
|
|
(apply hidden-field-generator
|
|
(cons value maybe-further-attributes)))))
|
|
(define set-hidden-field-value! set-simple-field-default!)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Password input field
|
|
(define make-password-field
|
|
(simple-field-maker "password" "password"
|
|
simple-default? identity))
|
|
(define set-password-field-value! set-simple-field-default!)
|
|
|
|
;;; That's it for simple input fields.
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Textarea input field
|
|
(define (make-textarea . 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-field-attributes
|
|
(and default-text)
|
|
(cons extra-attributes (sxml-attribute-attributes attributes)))
|
|
make-textarea-html-tree)))))
|
|
|
|
(define (make-textarea-html-tree textarea)
|
|
(let ((attributes (input-field-attributes textarea)))
|
|
`(textarea (@ (type "textarea")
|
|
(name ,(input-field-name textarea))
|
|
,(field-attributes-others attributes))
|
|
,(field-attributes-default attributes))))
|
|
|
|
(define set-textarea-value!
|
|
(let ((textarea-default-setter!
|
|
(make-simple-default-setter simple-default? #f)))
|
|
(lambda (textarea value)
|
|
(textarea-default-setter! textarea value))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Select input field
|
|
|
|
;(make-select '("this" "that" "those") '(@ ((id "sushi"))))
|
|
;(make-select '("this" ("that" '(@ (selected))) "those"))
|
|
;; dropdown: (size 1)
|
|
|
|
;;; A select input field shows a list of options that can be
|
|
;;; selected. For this purpose, we introduce an select-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 select-option :select-option
|
|
(really-make-select-option tag value selected? attributes)
|
|
select-option?
|
|
(tag select-option-tag)
|
|
(value select-option-value)
|
|
(selected? select-option-selected? really-set-select-option-selected?!)
|
|
(attributes select-option-attributes set-select-option-attributes!))
|
|
|
|
(define (make-select-option tag value selected? attributes)
|
|
(if (string? tag)
|
|
(really-make-select-option tag value selected?
|
|
(sxml-attribute-attributes attributes))
|
|
(error "Select-option's tag must be a string." tag)))
|
|
|
|
;; Constructor for valued select input-field option.
|
|
(define (make-annotated-select-option tag value . maybe-attributes)
|
|
(optionals maybe-attributes
|
|
((selected? boolean?)
|
|
(attributes sxml-attribute?))
|
|
(make-select-option tag value selected? attributes)))
|
|
|
|
;; Constructor for a simple select input-field option (not annotated).
|
|
(define (make-simple-select-option tag . maybe-attributes)
|
|
(optionals maybe-attributes
|
|
((selected? boolean?)
|
|
(attributes sxml-attribute?))
|
|
(make-select-option tag tag selected? attributes)))
|
|
|
|
(define-record-discloser :select-option
|
|
(lambda (select-option)
|
|
(list 'select-option
|
|
(select-option-tag select-option)
|
|
(select-option-value select-option)
|
|
(select-option-selected? select-option)
|
|
(select-option-attributes select-option)
|
|
)))
|
|
|
|
;; Selecting / Unselecting of an option in an select input-field,
|
|
;; chosen by tag.
|
|
(define (select-select-option! tag select)
|
|
(set-select-option-selected?! tag select #t))
|
|
|
|
(define (unselect-select-option! tag select)
|
|
(set-select-option-selected?! tag select #f))
|
|
|
|
(define (set-select-option-selected?! tag select selected?)
|
|
(let ((options (field-attributes-default
|
|
(input-field-attributes select))))
|
|
(if (number? tag) ; is tag an index?
|
|
(really-set-select-option-selected?! (list-ref options tag)
|
|
selected?)
|
|
(let lp ((options options))
|
|
(if (null? options)
|
|
(error "No such option" tag select)
|
|
(if (tag=select-option? tag (car options))
|
|
(really-set-select-option-selected?! (car options)
|
|
selected?)
|
|
(lp (cdr options))))))
|
|
(touch-input-field! select)))
|
|
|
|
;; Find select-option in a list by its tag.
|
|
(define (tag=select-option? tag select-option)
|
|
(string=? tag (select-option-tag select-option)))
|
|
|
|
(define (find-select-option tag select-options)
|
|
(cond ((member/srfi-1 tag select-options tag=select-option?)
|
|
=> car)
|
|
;; MEMBER/SRFI-1 returns the sublist that starts with the
|
|
;; searched element.
|
|
(else #f)))
|
|
|
|
(define (find-select-option-value tag select-options)
|
|
(cond ((find-select-option tag select-options)
|
|
=> select-option-value)
|
|
(else #f)))
|
|
|
|
(define (add-select-option! select select-option)
|
|
(let ((attributes (input-field-attributes select)))
|
|
(set-field-attributes-default!
|
|
attributes
|
|
(cons select-option
|
|
(field-attributes-default attributes)))
|
|
(touch-input-field! select)))
|
|
|
|
(define (delete-select-option! select select-option)
|
|
(let* ((attributes (input-field-attributes select))
|
|
(select-options (field-attributes-default attributes)))
|
|
(if (select-option? select-option)
|
|
(set-field-attributes-default!
|
|
attributes
|
|
(delete select-option select-options))
|
|
(let ((tag select-option))
|
|
(set-field-attributes-default!
|
|
attributes
|
|
(delete tag select-options tag=select-option?))))
|
|
(touch-input-field! select)))
|
|
|
|
;; 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 select-options-list (easily createable with
|
|
;; (map make-simple-select-option option-list))
|
|
(define (tolerate-old-select-options select-options)
|
|
(if (and (list? select-options)
|
|
(every select-option? select-options))
|
|
select-options
|
|
(map make-simple-select-option select-options)))
|
|
|
|
(define (make-select select-options . maybe-further-attributes)
|
|
(really-make-select (tolerate-old-select-options select-options)
|
|
maybe-further-attributes))
|
|
|
|
(define (make-annotated-select select-options .
|
|
maybe-further-attributes)
|
|
(really-make-select select-options maybe-further-attributes))
|
|
|
|
(define (really-make-select select-options maybe-further-attributes)
|
|
(let ((real-select-options (tolerate-old-select-options select-options)))
|
|
(optionals maybe-further-attributes
|
|
((multiple? boolean?)
|
|
(attributes sxml-attribute?))
|
|
(let ((name (generate-input-field-name "select")))
|
|
(if multiple?
|
|
(make-multiple-select name select-options attributes)
|
|
(make-single-select name select-options
|
|
attributes))))))
|
|
|
|
;; internal
|
|
(define (make-multiple-select name select-options attributes)
|
|
(make-multi-input-field name "mult-select"
|
|
select-multiple-transformer
|
|
(make-field-attributes
|
|
select-options
|
|
(list '(multiple)
|
|
(sxml-attribute-attributes attributes)))
|
|
make-select-html-tree))
|
|
|
|
;; internal
|
|
(define (make-single-select name select-options attributes)
|
|
(make-input-field name "select"
|
|
(lambda (tag)
|
|
(cond ((find-select-option-value tag select-options)
|
|
=> identity)
|
|
(else (error "no such option." tag))))
|
|
(make-field-attributes
|
|
select-options
|
|
(sxml-attribute-attributes attributes))
|
|
make-select-html-tree))
|
|
|
|
(define (select-multiple-transformer select bindings)
|
|
(let ((name (input-field-name select))
|
|
(select-options (field-attributes-default
|
|
(input-field-attributes select))))
|
|
(let* ((my-bindings (filter (lambda (binding)
|
|
(equal? (car binding) name))
|
|
bindings))
|
|
(tags (map cdr my-bindings)))
|
|
(filter-map (lambda (tag)
|
|
(find-select-option-value tag select-options))
|
|
tags))))
|
|
|
|
(define (make-select-html-tree select)
|
|
(let ((attributes (input-field-attributes select)))
|
|
`(select (@ (name ,(input-field-name select))
|
|
,(field-attributes-others attributes))
|
|
#\newline
|
|
,@(make-select-options-html-tree
|
|
(field-attributes-default attributes)))))
|
|
|
|
(define (make-select-options-html-tree select-options)
|
|
(map (lambda (select-option)
|
|
`(option (@ ,(and (select-option-selected? select-option) '(selected))
|
|
,(select-option-attributes select-option))
|
|
,(select-option-tag select-option)))
|
|
select-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-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-field-attributes
|
|
(if checked? '(checked) #f)
|
|
(list `(value ,value-string)
|
|
(sxml-attribute-attributes attributes)))
|
|
radio-html-tree-maker)))))
|
|
|
|
(define (make-annotated-radio-group)
|
|
(let* ((name (generate-input-field-name "radio"))
|
|
(value-table (make-integer-table))
|
|
(transformer (make-radio-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-field-attributes
|
|
(if checked? '(checked) #f)
|
|
(list`(value ,(number->string number))
|
|
(sxml-attribute-attributes attributes)))
|
|
radio-html-tree-maker))))))
|
|
|
|
(define (make-radios values . maybe-further-attributes)
|
|
(optionals maybe-further-attributes
|
|
((attributes sxml-attribute?))
|
|
(let ((radio-gen (make-annotated-radio-group)))
|
|
(map (lambda (value)
|
|
(if attributes
|
|
(radio-gen value attributes)
|
|
(radio-gen value)))
|
|
values))))
|
|
|
|
|
|
(define (make-radio-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-html-tree-maker radio)
|
|
(let* ((attributes (input-field-attributes radio)))
|
|
`(input (@ ((type "radio")
|
|
(name ,(input-field-name radio))
|
|
,(field-attributes-default attributes)
|
|
,(field-attributes-others attributes))))))
|
|
|
|
(define (set-input-field-checked?! input-field checked?)
|
|
(let ((attributes (input-field-attributes input-field)))
|
|
(set-field-attributes-default!
|
|
attributes
|
|
(if checked? '(checked) #f))
|
|
(touch-input-field! input-field)))
|
|
|
|
(define set-radio-checked?! set-input-field-checked?!)
|
|
(define (check-radio! radio) (set-radio-checked?! radio #t))
|
|
(define (uncheck-radio! radio) (set-radio-checked?! radio #f))
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; checkbox input-field
|
|
(define (make-checkbox . maybe-further-attributes)
|
|
(really-make-checkbox #t
|
|
checkbox-transformer
|
|
maybe-further-attributes))
|
|
|
|
(define (make-annotated-checkbox value . maybe-further-attributes)
|
|
(really-make-checkbox value
|
|
(make-checkbox-transformer value)
|
|
maybe-further-attributes))
|
|
|
|
(define (really-make-checkbox value transformer attributes)
|
|
(let ((name (generate-input-field-name "checkbox")))
|
|
(optionals attributes
|
|
((checked? boolean?)
|
|
(attributes sxml-attribute?))
|
|
(make-input-field name "checkbox"
|
|
transformer
|
|
(make-field-attributes
|
|
(if checked? '(checked) #f)
|
|
(sxml-attribute-attributes attributes))
|
|
checkbox-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-html-tree-maker checkbox)
|
|
(let ((attributes (input-field-attributes checkbox)))
|
|
`(input (@ ((type "checkbox")
|
|
(name ,(input-field-name checkbox))
|
|
,(field-attributes-default attributes)
|
|
,(field-attributes-others attributes))))))
|
|
|
|
(define set-checkbox-checked?! set-input-field-checked?!)
|
|
(define (check-checkbox! checkbox) (set-checkbox-checked?! checkbox #t))
|
|
(define (uncheck-checkbox! checkbox) (set-checkbox-checked?! checkbox #f))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;
|
|
;; button input-fields
|
|
(define (make-button type name button-caption attributes)
|
|
(make-input-field name type
|
|
identity
|
|
(make-field-attributes
|
|
(and button-caption `(value ,button-caption))
|
|
(sxml-attribute-attributes attributes))
|
|
make-button-html-tree))
|
|
|
|
(define (make-button-html-tree button)
|
|
(let ((attributes (input-field-attributes button)))
|
|
`(input (@ (type ,(input-field-type button))
|
|
(name ,(input-field-name button))
|
|
,(field-attributes-default attributes)
|
|
,(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-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 |