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

531 lines
19 KiB
Scheme
Raw Normal View History

;;; SUrflets' input fields
;;; Copyright 2002, 2003 Andreas Bernauer
2003-05-22 09:55:03 -04:00
;;; 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)))))
2003-05-22 09:55:03 -04:00
;; 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)))
2003-05-22 09:55:03 -04:00
;; 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