scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Change names in surflet-input-fields.scm, so that they are both short and 

descriptive and not misleading.

If you have written SUrflets that use the input field feature, you must
rename your input field commands to get them work with this change.
Contact me, if you want to have a small script that does this for you.
This commit is contained in:
interp 2003-07-08 21:22:06 +00:00
parent e66223b666
commit c1d14a06a0
13 changed files with 306 additions and 316 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
scheme/httpd/surflets/packages.scm
View File

@ -309,44 +309,44 @@
(define-interface surflets/surflet-input-fields-interface (define-interface surflets/surflet-input-fields-interface
(compound-interface (compound-interface
surflets/input-field-value-interface surflets/input-field-value-interface
(export make-text-input-field (export make-text-field
set-text-input-field-value! set-text-field-value!
make-number-input-field make-number-field
set-number-input-field-value! set-number-field-value!
make-hidden-input-field make-hidden-field
set-hidden-input-field-value! set-hidden-field-value!
make-password-input-field make-password-field
set-password-input-field-value! set-password-field-value!
make-textarea-input-field make-textarea
set-textarea-input-field-value! set-textarea-value!
make-select-input-field make-select
make-annotated-select-input-field make-annotated-select
make-simple-sel-if-option make-simple-select-option
make-annotated-sel-if-option make-annotated-select-option
sel-if-option? select-option?
select-sel-if-option! select-select-option!
unselect-sel-if-option! unselect-select-option!
add-sel-if-option! add-select-option!
delete-sel-if-option! delete-select-option!
set-sel-if-option-selected?! set-select-option-selected?!
make-radio-input-field-group make-radio-group
make-annotated-radio-input-field-group make-annotated-radio-group
make-radio-input-fields make-radios
check-radio-input-field! check-radio!
uncheck-radio-input-field! uncheck-radio!
set-radio-input-field-checked?! set-radio-checked?!
make-checkbox-input-field make-checkbox
make-annotated-checkbox-input-field make-annotated-checkbox
check-checkbox-input-field! check-checkbox!
uncheck-checkbox-input-field! uncheck-checkbox!
set-checkbox-input-field-checked?! set-checkbox-checked?!
make-submit-button make-submit-button
make-reset-button make-reset-button

10
scheme/httpd/surflets/simple-surflet-api.scm
View File

@ -116,16 +116,16 @@
(else (no-method message))))) (else (no-method message)))))
(define (make-text text) (define (make-text text)
(standard-query text (make-text-input-field) "No bad input possible")) (standard-query text (make-text-field) "No bad input possible"))
(define (make-password text) (define (make-password text)
(standard-query text (make-password-input-field) "No bad input possible")) (standard-query text (make-password-field) "No bad input possible"))
(define (make-number text) (define (make-number text)
(standard-query text (make-number-input-field) "Please respond with a valid number")) (standard-query text (make-number-field) "Please respond with a valid number"))
(define (make-boolean text) (define (make-boolean text)
(let* ((input-field (make-checkbox-input-field)) (let* ((input-field (make-checkbox))
(standard (standard-query text input-field "No bad input possible"))) (standard (standard-query text input-field "No bad input possible")))
(lambda (message) (lambda (message)
(case message (case message
@ -139,7 +139,7 @@
(define (make-radio text choices . maybe-insist) (define (make-radio text choices . maybe-insist)
(let* ((insist (:optional maybe-insist "")) (let* ((insist (:optional maybe-insist ""))
(radios (make-radio-input-fields choices)) (radios (make-radios choices))
(standard (standard-query text (car radios) (standard (standard-query text (car radios)
(string-append "Please respond" insist)))) (string-append "Please respond" insist))))
(lambda (message) (lambda (message)

431
scheme/httpd/surflets/surflet-input-fields.scm
View File

@ -8,17 +8,17 @@
;; The interface for input-fields does not prescribe what the type of ;; The interface for input-fields does not prescribe what the type of
;; attributes has to be. We choose a record here. ;; attributes has to be. We choose a record here.
(define-record-type input-field-attributes :input-field-attributes (define-record-type field-attributes :field-attributes
(make-input-field-attributes default others) (make-field-attributes default others)
input-field-attributes? field-attributes?
(default input-field-attributes-default set-input-field-attributes-default!) (default field-attributes-default set-field-attributes-default!)
(others input-field-attributes-others set-input-field-attributes-others!)) (others field-attributes-others set-field-attributes-others!))
;; A simple input-field is a prototype for other input-fields. ;; A simple input-field is a prototype for other input-fields.
;; REPORTED-TYPE is the type of the input-field in HTML, TYPE the ;; REPORTED-TYPE is the type of the input-field in HTML, TYPE the
;; internal referenced type and TRANSFORMER the function that ;; internal referenced type and TRANSFORMER the function that
;; translates the HTTP-string of the request into a scheme value. ;; translates the HTTP-string of the request into a scheme value.
(define (simple-input-field-maker reported-type type default-pred transformer) (define (simple-field-maker reported-type type default-pred transformer)
(lambda maybe-further-attributes (lambda maybe-further-attributes
(let ((name (generate-input-field-name type))) (let ((name (generate-input-field-name type)))
(optionals maybe-further-attributes (optionals maybe-further-attributes
@ -26,24 +26,23 @@
(attributes sxml-attribute?)) (attributes sxml-attribute?))
(make-input-field name type (make-input-field name type
transformer transformer
(make-input-field-attributes (make-field-attributes
(and default `(value ,default)) (and default `(value ,default))
(sxml-attribute-attributes attributes)) (sxml-attribute-attributes attributes))
(simple-input-field-maker-html-tree-maker (simple-html-tree-maker reported-type))))))
reported-type))))))
(define (simple-input-field-maker-html-tree-maker reported-type) (define (simple-html-tree-maker reported-type)
(lambda (input-field) (lambda (input-field)
(let ((attributes (input-field-attributes input-field))) (let ((attributes (input-field-attributes input-field)))
`(input (@ (type ,reported-type) `(input (@ (type ,reported-type)
(name ,(input-field-name input-field)) (name ,(input-field-name input-field))
,(input-field-attributes-default attributes) ,(field-attributes-default attributes)
,(input-field-attributes-others attributes)))))) ,(field-attributes-others attributes))))))
(define (make-simple-input-field-default-setter default-pred? wrap?) (define (make-simple-default-setter default-pred? wrap?)
(lambda (input-field value) (lambda (input-field value)
(if (default-pred? value) (if (default-pred? value)
(set-input-field-attributes-default! (set-field-attributes-default!
(input-field-attributes input-field) (input-field-attributes input-field)
(if wrap? `(value ,value) value)) (if wrap? `(value ,value) value))
(error "Default value must be a number or a string or a symbol." (error "Default value must be a number or a string or a symbol."
@ -54,58 +53,54 @@
(or (string? thing) (symbol? thing))) (or (string? thing) (symbol? thing)))
(define simple-default? string-or-symbol?) (define simple-default? string-or-symbol?)
(define set-simple-input-field-default! (define set-simple-field-default!
(make-simple-input-field-default-setter simple-default? #t)) (make-simple-default-setter simple-default? #t))
;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;
;;; Text input field ;;; Text input field
(define make-text-input-field (define make-text-field
(simple-input-field-maker "text" "text" (simple-field-maker "text" "text" simple-default? identity))
simple-default? identity)) (define set-text-field-value! set-simple-field-default!)
(define set-text-input-field-value! set-simple-input-field-default!)
;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;
;;; Number input field ;;; Number input field
(define (number-input-field-default? value) (define (number-field-default? value)
(or (number? value) (or (number? value)
(simple-default? value))) (simple-default? value)))
(define (number-input-field-transformer string) (define (number-field-transformer string)
(or (string->number string) (or (string->number string)
(error "wrong type"))) (error "wrong type")))
(define make-number-input-field (define make-number-field
(simple-input-field-maker "text" "number" (simple-field-maker "text" "number"
number-input-field-default? number-field-default? number-field-transformer))
number-input-field-transformer)) (define set-number-field-value!
(define set-number-input-field-value! (make-simple-default-setter number-field-default? #t))
(make-simple-input-field-default-setter number-input-field-default? #t))
;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;
;;; hidden input-field ;;; hidden input-field
;; Little workaraound, as a hidden input-field needs a value. This ;; Little workaraound, as a hidden input-field needs a value. This
;; value is propagated in the slot "default value". ;; value is propagated in the slot "default value".
(define make-hidden-input-field (define make-hidden-field
(let ((hidden-input-field-generator (let ((hidden-field-generator
(simple-input-field-maker "hidden" "text" (simple-field-maker "hidden" "text"
simple-default? identity))) simple-default? identity)))
(lambda (value . maybe-further-attributes) (lambda (value . maybe-further-attributes)
(apply hidden-input-field-generator (apply hidden-field-generator
(cons value maybe-further-attributes))))) (cons value maybe-further-attributes)))))
(define set-hidden-input-field-value! (define set-hidden-field-value! set-simple-field-default!)
set-simple-input-field-default!)
;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;
;;; Password input field ;;; Password input field
(define make-password-input-field (define make-password-field
(simple-input-field-maker "password" "password" (simple-field-maker "password" "password"
simple-default? identity)) simple-default? identity))
(define set-password-input-field-value! (define set-password-field-value! set-simple-field-default!)
set-simple-input-field-default!)
;;; That's it for simple input fields. ;;; That's it for simple input fields.
;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;
;;; Textarea input field ;;; Textarea input field
(define (make-textarea-input-field . maybe-further-attributes) (define (make-textarea . maybe-further-attributes)
(let ((name (generate-input-field-name "textarea"))) (let ((name (generate-input-field-name "textarea")))
(optionals maybe-further-attributes (optionals maybe-further-attributes
((default-text simple-default?) ((default-text simple-default?)
@ -121,34 +116,33 @@
(make-input-field (make-input-field
name "textarea" name "textarea"
identity identity
(make-input-field-attributes (make-field-attributes
(and default-text) (and default-text)
(cons extra-attributes (sxml-attribute-attributes attributes))) (cons extra-attributes (sxml-attribute-attributes attributes)))
make-textarea-input-field-html-tree))))) make-textarea-html-tree)))))
(define (make-textarea-input-field-html-tree input-field) (define (make-textarea-html-tree textarea)
(let ((attributes (input-field-attributes input-field))) (let ((attributes (input-field-attributes textarea)))
`(textarea (@ (type "textarea") `(textarea (@ (type "textarea")
(name ,(input-field-name input-field)) (name ,(input-field-name textarea))
,(input-field-attributes-others attributes)) ,(field-attributes-others attributes))
,(input-field-attributes-default attributes)))) ,(field-attributes-default attributes))))
(define set-textarea-input-field-value! (define set-textarea-value!
(let ((textarea-default-setter! (let ((textarea-default-setter!
(make-simple-input-field-default-setter simple-default? #f))) (make-simple-default-setter simple-default? #f)))
(lambda (textarea-input-field value) (lambda (textarea value)
(textarea-default-setter! textarea-input-field value)))) (textarea-default-setter! textarea value))))
;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Selection input field ;;; Select input field
;; sel-if == select-input-field ;(make-select '("this" "that" "those") '(@ ((id "sushi"))))
;(make-select-input-fields '("this" "that" "those") '(@ ((id "sushi")))) ;(make-select '("this" ("that" '(@ (selected))) "those"))
;(make-select-input-fields '("this" ("that" '(@ (selected))) "those"))
;; dropdown: (size 1) ;; dropdown: (size 1)
;;; A selection input field shows a list of options that can be ;;; A select input field shows a list of options that can be
;;; selected. For this purpose, we introduce an sel-if-option record, ;;; selected. For this purpose, we introduce an select-option record,
;;; that contains all the information for each option. This is ;;; that contains all the information for each option. This is
;;; justified by the fact, that the options list is seperated in HTML, ;;; 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 ;;; too. The TAG is the string that is displayed in the website, the
@ -156,187 +150,187 @@
;;; option was selected. TAG is assumed to be unique by some functions ;;; option was selected. TAG is assumed to be unique by some functions
;;; (e.g. select and unselect) SELECTED? tells us, if this option is ;;; (e.g. select and unselect) SELECTED? tells us, if this option is
;;; preselected. ;;; preselected.
(define-record-type sel-if-option :sel-if-option (define-record-type select-option :select-option
(really-make-sel-if-option tag value selected? attributes) (really-make-select-option tag value selected? attributes)
sel-if-option? select-option?
(tag sel-if-option-tag) (tag select-option-tag)
(value sel-if-option-value) (value select-option-value)
(selected? sel-if-option-selected? set-sel-if-option-selected?!) (selected? select-option-selected? really-set-select-option-selected?!)
(attributes sel-if-option-attributes set-sel-if-option-attributes!)) (attributes select-option-attributes set-select-option-attributes!))
(define (make-sel-if-option tag value selected? attributes) (define (make-select-option tag value selected? attributes)
(if (string? tag) (if (string? tag)
(really-make-sel-if-option tag value selected? (really-make-select-option tag value selected?
(sxml-attribute-attributes attributes)) (sxml-attribute-attributes attributes))
(error "Select-input-field-option's tag must be a string." tag))) (error "Select-option's tag must be a string." tag)))
;; Constructor for valued select input-field option. ;; Constructor for valued select input-field option.
(define (make-annotated-sel-if-option tag value . maybe-attributes) (define (make-annotated-select-option tag value . maybe-attributes)
(optionals maybe-attributes (optionals maybe-attributes
((selected? boolean?) ((selected? boolean?)
(attributes sxml-attribute?)) (attributes sxml-attribute?))
(make-sel-if-option tag value selected? attributes))) (make-select-option tag value selected? attributes)))
;; Constructor for a simple select input-field option (not annotated). ;; Constructor for a simple select input-field option (not annotated).
(define (make-simple-sel-if-option tag . maybe-attributes) (define (make-simple-select-option tag . maybe-attributes)
(optionals maybe-attributes (optionals maybe-attributes
((selected? boolean?) ((selected? boolean?)
(attributes sxml-attribute?)) (attributes sxml-attribute?))
(make-sel-if-option tag tag selected? attributes))) (make-select-option tag tag selected? attributes)))
(define-record-discloser :sel-if-option (define-record-discloser :select-option
(lambda (sel-if-option) (lambda (select-option)
(list 'select-input-field-option (list 'select-option
(sel-if-option-tag sel-if-option) (select-option-tag select-option)
(sel-if-option-value sel-if-option) (select-option-value select-option)
(sel-if-option-selected? sel-if-option) (select-option-selected? select-option)
(sel-if-option-attributes sel-if-option) (select-option-attributes select-option)
))) )))
;; Selecting / Unselecting of an option in an select input-field, ;; Selecting / Unselecting of an option in an select input-field,
;; chosen by tag. ;; chosen by tag.
(define (select-sel-if-option! tag sel-if) (define (select-select-option! tag select)
(set-select-input-field-option-selected?! tag sel-if #t)) (set-select-option-selected?! tag select #t))
(define (unselect-sel-if-option! tag sel-if) (define (unselect-select-option! tag select)
(set-select-input-field-option-selected?! tag sel-if #f)) (set-select-option-selected?! tag select #f))
(define (set-select-input-field-option-selected?! tag sel-if selected?) (define (set-select-option-selected?! tag select selected?)
(let ((options (input-field-attributes-default (let ((options (field-attributes-default
(input-field-attributes sel-if)))) (input-field-attributes select))))
(if (number? tag) ; is tag an index? (if (number? tag) ; is tag an index?
(set-sel-if-option-selected?! (list-ref options tag) (really-set-select-option-selected?! (list-ref options tag)
selected?) selected?)
(let lp ((options options)) (let lp ((options options))
(if (null? options) (if (null? options)
(error "No such option" tag sel-if) (error "No such option" tag select)
(if (tag=sel-if-option? tag (car options)) (if (tag=select-option? tag (car options))
(set-sel-if-option-selected?! (car options) selected?) (really-set-select-option-selected?! (car options)
selected?)
(lp (cdr options)))))) (lp (cdr options))))))
(touch-input-field! sel-if))) (touch-input-field! select)))
;; Find sel-if-option in a list by its tag. ;; Find select-option in a list by its tag.
(define (tag=sel-if-option? tag sel-if-option) (define (tag=select-option? tag select-option)
(string=? tag (sel-if-option-tag sel-if-option))) (string=? tag (select-option-tag select-option)))
(define (find-sel-if-option tag sel-if-options) (define (find-select-option tag select-options)
(cond ((member/srfi-1 tag sel-if-options tag=sel-if-option?) (cond ((member/srfi-1 tag select-options tag=select-option?)
=> car) => car)
;; MEMBER/SRFI-1 returns the sublist that starts with the ;; MEMBER/SRFI-1 returns the sublist that starts with the
;; searched element. ;; searched element.
(else #f))) (else #f)))
(define (find-sel-if-option-value tag sel-if-options) (define (find-select-option-value tag select-options)
(cond ((find-sel-if-option tag sel-if-options) (cond ((find-select-option tag select-options)
=> sel-if-option-value) => select-option-value)
(else #f))) (else #f)))
(define (add-sel-if-option! sel-if sel-if-option) (define (add-select-option! select select-option)
(let ((attributes (input-field-attributes sel-if))) (let ((attributes (input-field-attributes select)))
(set-input-field-attributes-default! (set-field-attributes-default!
attributes attributes
(cons sel-if-option (cons select-option
(input-field-attributes-default attributes))) (field-attributes-default attributes)))
(touch-input-field! sel-if))) (touch-input-field! select)))
(define (delete-sel-if-option! sel-if sel-if-option) (define (delete-select-option! select select-option)
(let* ((attributes (input-field-attributes sel-if)) (let* ((attributes (input-field-attributes select))
(sel-if-options (input-field-attributes-default attributes))) (select-options (field-attributes-default attributes)))
(if (sel-if-option? sel-if-option) (if (select-option? select-option)
(set-input-field-attributes-default! (set-field-attributes-default!
attributes attributes
(delete sel-if-option sel-if-options)) (delete select-option select-options))
(let ((tag sel-if-option)) (let ((tag select-option))
(set-input-field-attributes-default! (set-field-attributes-default!
attributes attributes
(delete tag sel-if-options tag=sel-if-option?)))) (delete tag select-options tag=select-option?))))
(touch-input-field! sel-if))) (touch-input-field! select)))
;; To be compatible with previous versions of MAKE-SELECT-INPUT-FIELD, ;; To be compatible with previous versions of MAKE-SELECT-INPUT-FIELD,
;; we accept also a simple list as an option-list. New programs should ;; we accept also a simple list as an option-list. New programs should
;; use sel-if-options-list (easily createable with ;; use select-options-list (easily createable with
;; (map make-simple-sel-if-option option-list)) ;; (map make-simple-select-option option-list))
(define (tolerate-old-sel-if-options sel-if-options) (define (tolerate-old-select-options select-options)
(if (and (list? sel-if-options) (if (and (list? select-options)
(every sel-if-option? sel-if-options)) (every select-option? select-options))
sel-if-options select-options
(map make-simple-sel-if-option sel-if-options))) (map make-simple-select-option select-options)))
(define (make-select-input-field sel-if-options . maybe-further-attributes) (define (make-select select-options . maybe-further-attributes)
(really-make-select-input-field (tolerate-old-sel-if-options sel-if-options) (really-make-select (tolerate-old-select-options select-options)
maybe-further-attributes)) maybe-further-attributes))
(define (make-annotated-select-input-field sel-if-options . (define (make-annotated-select select-options .
maybe-further-attributes) maybe-further-attributes)
(really-make-select-input-field sel-if-options maybe-further-attributes)) (really-make-select select-options maybe-further-attributes))
(define (really-make-select-input-field sel-if-options (define (really-make-select select-options maybe-further-attributes)
maybe-further-attributes) (let ((real-select-options (tolerate-old-select-options select-options)))
(let ((real-sel-if-options (tolerate-old-sel-if-options sel-if-options)))
(optionals maybe-further-attributes (optionals maybe-further-attributes
((multiple? boolean?) ((multiple? boolean?)
(attributes sxml-attribute?)) (attributes sxml-attribute?))
(let ((name (generate-input-field-name "select"))) (let ((name (generate-input-field-name "select")))
(if multiple? (if multiple?
(make-multiple-select-input-field name sel-if-options attributes) (make-multiple-select name select-options attributes)
(make-single-select-input-field name sel-if-options (make-single-select name select-options
attributes)))))) attributes))))))
;; internal ;; internal
(define (make-multiple-select-input-field name sel-if-options attributes) (define (make-multiple-select name select-options attributes)
(make-multi-input-field name "mult-select" (make-multi-input-field name "mult-select"
sel-if-multiple-transformer select-multiple-transformer
(make-input-field-attributes (make-field-attributes
sel-if-options select-options
(list '(multiple) (list '(multiple)
(sxml-attribute-attributes attributes))) (sxml-attribute-attributes attributes)))
make-sel-if-html-tree)) make-select-html-tree))
;; internal ;; internal
(define (make-single-select-input-field name sel-if-options attributes) (define (make-single-select name select-options attributes)
(make-input-field name "select" (make-input-field name "select"
(lambda (tag) (lambda (tag)
(cond ((find-sel-if-option-value tag sel-if-options) (cond ((find-select-option-value tag select-options)
=> identity) => identity)
(else (error "no such option." tag)))) (else (error "no such option." tag))))
(make-input-field-attributes (make-field-attributes
sel-if-options select-options
(sxml-attribute-attributes attributes)) (sxml-attribute-attributes attributes))
make-sel-if-html-tree)) make-select-html-tree))
(define (sel-if-multiple-transformer input-field bindings) (define (select-multiple-transformer select bindings)
(let ((name (input-field-name input-field)) (let ((name (input-field-name select))
(sel-if-options (input-field-attributes-default (select-options (field-attributes-default
(input-field-attributes input-field)))) (input-field-attributes select))))
(let* ((my-bindings (filter (lambda (binding) (let* ((my-bindings (filter (lambda (binding)
(equal? (car binding) name)) (equal? (car binding) name))
bindings)) bindings))
(tags (map cdr my-bindings))) (tags (map cdr my-bindings)))
(filter-map (lambda (tag) (filter-map (lambda (tag)
(find-sel-if-option-value tag sel-if-options)) (find-select-option-value tag select-options))
tags)))) tags))))
(define (make-sel-if-html-tree sel-if) (define (make-select-html-tree select)
(let ((attributes (input-field-attributes sel-if))) (let ((attributes (input-field-attributes select)))
`(select (@ (name ,(input-field-name sel-if)) `(select (@ (name ,(input-field-name select))
,(input-field-attributes-others attributes)) ,(field-attributes-others attributes))
#\newline #\newline
,@(make-sel-if-options-html-tree ,@(make-select-options-html-tree
(input-field-attributes-default attributes))))) (field-attributes-default attributes)))))
(define (make-sel-if-options-html-tree sel-if-options) (define (make-select-options-html-tree select-options)
(map (lambda (sel-if-option) (map (lambda (select-option)
`(option (@ ,(and (sel-if-option-selected? sel-if-option) '(selected)) `(option (@ ,(and (select-option-selected? select-option) '(selected))
,(sel-if-option-attributes sel-if-option)) ,(select-option-attributes select-option))
,(sel-if-option-tag sel-if-option))) ,(select-option-tag select-option)))
sel-if-options)) select-options))
;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;
;;; radio input-fields ;;; radio input-fields
;; Because grouped radio input-fields must use the same name, we ;; Because grouped radio input-fields must use the same name, we
;; cannot just return one radio input-field object, but we must ;; cannot just return one radio input-field object, but we must
;; generate several ones with the same name. ;; generate several ones with the same name.
(define (make-radio-input-field-group) (define (make-radio-group)
(let ((name (generate-input-field-name "radio"))) (let ((name (generate-input-field-name "radio")))
(lambda (value-string . maybe-further-attributes) (lambda (value-string . maybe-further-attributes)
(optionals maybe-further-attributes (optionals maybe-further-attributes
@ -344,16 +338,16 @@
(attributes sxml-attribute?)) (attributes sxml-attribute?))
(make-input-field name "radio" (make-input-field name "radio"
identity identity
(make-input-field-attributes (make-field-attributes
(if checked? '(checked) #f) (if checked? '(checked) #f)
(list `(value ,value-string) (list `(value ,value-string)
(sxml-attribute-attributes attributes))) (sxml-attribute-attributes attributes)))
radio-input-field-html-tree-maker))))) radio-html-tree-maker)))))
(define (make-annotated-radio-input-field-group) (define (make-annotated-radio-group)
(let* ((name (generate-input-field-name "radio")) (let* ((name (generate-input-field-name "radio"))
(value-table (make-integer-table)) (value-table (make-integer-table))
(transformer (make-radio-input-field-transformer value-table))) (transformer (make-radio-transformer value-table)))
(lambda (value . maybe-further-attributes) (lambda (value . maybe-further-attributes)
(optionals maybe-further-attributes (optionals maybe-further-attributes
((checked? boolean?) ((checked? boolean?)
@ -362,16 +356,16 @@
(table-set! value-table number value) (table-set! value-table number value)
(make-input-field name "radio" (make-input-field name "radio"
transformer transformer
(make-input-field-attributes (make-field-attributes
(if checked? '(checked) #f) (if checked? '(checked) #f)
(list`(value ,(number->string number)) (list`(value ,(number->string number))
(sxml-attribute-attributes attributes))) (sxml-attribute-attributes attributes)))
radio-input-field-html-tree-maker)))))) radio-html-tree-maker))))))
(define (make-radio-input-fields values . maybe-further-attributes) (define (make-radios values . maybe-further-attributes)
(optionals maybe-further-attributes (optionals maybe-further-attributes
((attributes sxml-attribute?)) ((attributes sxml-attribute?))
(let ((radio-gen (make-annotated-radio-input-field-group))) (let ((radio-gen (make-annotated-radio-group)))
(map (lambda (value) (map (lambda (value)
(if attributes (if attributes
(radio-gen value attributes) (radio-gen value attributes)
@ -379,7 +373,7 @@
values)))) values))))
(define (make-radio-input-field-transformer value-table) (define (make-radio-transformer value-table)
(lambda (tag) (lambda (tag)
(cond (cond
((string->number tag) => ((string->number tag) =>
@ -391,48 +385,46 @@
(else (else
(error "Unknown tag number for radio input-field" tag))))) (error "Unknown tag number for radio input-field" tag)))))
(define (radio-input-field-html-tree-maker radio-input-field) (define (radio-html-tree-maker radio)
(let* ((attributes (input-field-attributes radio-input-field))) (let* ((attributes (input-field-attributes radio)))
`(input (@ ((type "radio") `(input (@ ((type "radio")
(name ,(input-field-name radio-input-field)) (name ,(input-field-name radio))
,(input-field-attributes-default attributes) ,(field-attributes-default attributes)
,(input-field-attributes-others attributes)))))) ,(field-attributes-others attributes))))))
(define (set-input-field-checked?! input-field checked?) (define (set-input-field-checked?! input-field checked?)
(let ((attributes (input-field-attributes input-field))) (let ((attributes (input-field-attributes input-field)))
(set-input-field-attributes-default! (set-field-attributes-default!
attributes attributes
(if checked? '(checked) #f)) (if checked? '(checked) #f))
(touch-input-field! input-field))) (touch-input-field! input-field)))
(define set-radio-input-field-checked?! set-input-field-checked?!) (define set-radio-checked?! set-input-field-checked?!)
(define (check-radio-input-field! radio) (define (check-radio! radio) (set-radio-checked?! radio #t))
(set-radio-input-field-checked?! radio #t)) (define (uncheck-radio! radio) (set-radio-checked?! radio #f))
(define (uncheck-radio-input-field! radio)
(set-radio-input-field-checked?! radio #f))
;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;
;;; checkbox input-field ;;; checkbox input-field
(define (make-checkbox-input-field . maybe-further-attributes) (define (make-checkbox . maybe-further-attributes)
(really-make-checkbox-input-field #t (really-make-checkbox #t
checkbox-transformer checkbox-transformer
maybe-further-attributes)) maybe-further-attributes))
(define (make-annotated-checkbox-input-field value . maybe-further-attributes) (define (make-annotated-checkbox value . maybe-further-attributes)
(really-make-checkbox-input-field value (really-make-checkbox value
(make-checkbox-transformer value) (make-checkbox-transformer value)
maybe-further-attributes)) maybe-further-attributes))
(define (really-make-checkbox-input-field value transformer attributes) (define (really-make-checkbox value transformer attributes)
(let ((name (generate-input-field-name "checkbox"))) (let ((name (generate-input-field-name "checkbox")))
(optionals attributes (optionals attributes
((checked? boolean?) ((checked? boolean?)
(attributes sxml-attribute?)) (attributes sxml-attribute?))
(make-input-field name "checkbox" (make-input-field name "checkbox"
transformer transformer
(make-input-field-attributes (make-field-attributes
(if checked? '(checked) #f) (if checked? '(checked) #f)
(sxml-attribute-attributes attributes)) (sxml-attribute-attributes attributes))
checkbox-input-field-html-tree-maker)))) checkbox-html-tree-maker))))
(define (make-checkbox-transformer value) (define (make-checkbox-transformer value)
(lambda (tag) (lambda (tag)
@ -440,37 +432,36 @@
value value
#f))) #f)))
(define checkbox-transformer (define checkbox-transformer (make-checkbox-transformer #t))
(make-checkbox-transformer #t))
(define (checkbox-input-field-html-tree-maker cb-if) (define (checkbox-html-tree-maker checkbox)
(let ((attributes (input-field-attributes cb-if))) (let ((attributes (input-field-attributes checkbox)))
`(input (@ ((type "checkbox") `(input (@ ((type "checkbox")
(name ,(input-field-name cb-if)) (name ,(input-field-name checkbox))
,(input-field-attributes-default attributes) ,(field-attributes-default attributes)
,(input-field-attributes-others 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))
(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 ;; button input-fields
(define (make-button type name button-caption attributes) (define (make-button type name button-caption attributes)
(make-input-field name type (make-input-field name type
identity identity
(make-input-field-attributes (make-field-attributes
(and button-caption `(value ,button-caption)) (and button-caption `(value ,button-caption))
(sxml-attribute-attributes attributes)) (sxml-attribute-attributes attributes))
make-button-html-tree)) make-button-html-tree))
(define (make-button-html-tree button-input-field) (define (make-button-html-tree button)
(let ((attributes (input-field-attributes button-input-field))) (let ((attributes (input-field-attributes button)))
`(input (@ (type ,(input-field-type button-input-field)) `(input (@ (type ,(input-field-type button))
(name ,(input-field-name button-input-field)) (name ,(input-field-name button))
,(input-field-attributes-default attributes) ,(field-attributes-default attributes)
,(input-field-attributes-others attributes))))) ,(field-attributes-others attributes)))))
(define (make-submit-button . maybe-further-attributes) (define (make-submit-button . maybe-further-attributes)
(optionals maybe-further-attributes (optionals maybe-further-attributes
@ -502,7 +493,7 @@
(make-multi-input-field (generate-input-field-name "imgbtn") (make-multi-input-field (generate-input-field-name "imgbtn")
"image" "image"
image-button-transformer image-button-transformer
(make-input-field-attributes (make-field-attributes
`(src ,image-source) `(src ,image-source)
(sxml-attribute-attributes attributes)) (sxml-attribute-attributes attributes))
make-button-html-tree))) make-button-html-tree)))
@ -514,10 +505,10 @@
(y (find-image-button-coordinate image-button bindings ".y"))) (y (find-image-button-coordinate image-button bindings ".y")))
(let ((x-number (string->number x)) (let ((x-number (string->number x))
(y-number (string->number y))) (y-number (string->number y)))
(and x y (and x y
(if (and x-number y-number) (if (and x-number y-number)
(cons x-number y-number) (cons x-number y-number)
(error "Image button coordinates aren't numbers. " x y)))))) (error "Image button coordinates aren't numbers. " x y))))))
(define (find-image-button-coordinate image-button bindings suffix) (define (find-image-button-coordinate image-button bindings suffix)
(let* ((name (input-field-name image-button))) (let* ((name (input-field-name image-button)))

2
scheme/httpd/surflets/web-server/root/surflets/add-surflet.scm
View File

@ -3,7 +3,7 @@
scheme-with-scsh) scheme-with-scsh)
(begin (begin
(define number-input (make-number-input-field)) (define number-input (make-number-field))
(define (create-input-page title input-text number-input) (define (create-input-page title input-text number-input)
(lambda (new-url) (lambda (new-url)

4
scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm
View File

@ -44,8 +44,8 @@
(let* ((update-text `(font (@ (color "red")) (let* ((update-text `(font (@ (color "red"))
,(:optional maybe-update-text ""))) ,(:optional maybe-update-text "")))
(number-field (number-field
(make-number-input-field (options-session-lifetime))) (make-number-field (options-session-lifetime)))
(cache-checkbox (make-checkbox-input-field (options-cache-surflets?))) (cache-checkbox (make-checkbox (options-cache-surflets?)))
(options `(("Current session lifetime: " ,number-field ,submit-timeout) (options `(("Current session lifetime: " ,number-field ,submit-timeout)
("Cache SUrflets?" ,cache-checkbox ,submit-cache))) ("Cache SUrflets?" ,cache-checkbox ,submit-cache)))
(req (get-option-change return-address update-text options)) (req (get-option-change return-address update-text options))

6
scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm
View File

@ -39,10 +39,10 @@
(define (profile req . maybe-update-text) (define (profile req . maybe-update-text)
(let* ((update-text (:optional maybe-update-text "")) (let* ((update-text (:optional maybe-update-text ""))
(gnuplot-input-field (make-text-input-field gnuplot '(@ (size 20)))) (gnuplot-input-field (make-text-field gnuplot '(@ (size 20))))
(gnuplot-change-button (make-submit-button "Change")) (gnuplot-change-button (make-submit-button "Change"))
(convert-check-box (make-checkbox-input-field use-convert?)) (convert-check-box (make-checkbox use-convert?))
(convert-input-field (make-text-input-field convert '(@ (size 20)))) (convert-input-field (make-text-field convert '(@ (size 20))))
(convert-change-button (make-submit-button "Change")) (convert-change-button (make-submit-button "Change"))
(new-profile-address (make-address)) (new-profile-address (make-address))
(result-address (make-address)) (result-address (make-address))

4
scheme/httpd/surflets/web-server/root/surflets/admin-surflets-cb.scm
View File

@ -26,10 +26,10 @@
(define (select-table title header header-row (define (select-table title header header-row
table-elements selector actions footer) table-elements selector actions footer)
(let* ((checkboxes (map (lambda (_) (let* ((checkboxes (map (lambda (_)
(make-checkbox-input-field)) (make-checkbox))
table-elements)) table-elements))
(action-title "Choose an action") (action-title "Choose an action")
(select (make-select-input-field (cons action-title actions) (select (make-select (cons action-title actions)
'(@ (size 1)))) '(@ (size 1))))
(req (req
(send-html/suspend (send-html/suspend

10
scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm
View File

@ -26,9 +26,9 @@
;; list of selected elements out of TABLE-ELEMENTS. ;; list of selected elements out of TABLE-ELEMENTS.
(define (select-table title header header-row (define (select-table title header header-row
table-elements selector actions footer) table-elements selector actions footer)
(let* ((checkboxes (map make-annotated-checkbox-input-field (let* ((checkboxes (map make-annotated-checkbox
table-elements)) table-elements))
(select (make-annotated-select-input-field (select (make-annotated-select
actions '(@ (size 1)))) actions '(@ (size 1))))
(req (req
(send-html/suspend (send-html/suspend
@ -98,7 +98,7 @@
(body ,header ,(no-surflets callback) ,footer))) (body ,header ,(no-surflets callback) ,footer)))
(let ((actions (let ((actions
(map (lambda (action-pair) (map (lambda (action-pair)
(make-annotated-sel-if-option (make-annotated-select-option
(car action-pair) (car action-pair)
(cdr action-pair))) (cdr action-pair)))
`(("Choose an action" . ,(choose-an-action show-surflets)) `(("Choose an action" . ,(choose-an-action show-surflets))
@ -200,7 +200,7 @@
(body ,@header ,(no-current-sessions) ,footer))) (body ,@header ,(no-current-sessions) ,footer)))
(let ((actions (let ((actions
(map (lambda (action-pair) (map (lambda (action-pair)
(make-annotated-sel-if-option (make-annotated-select-option
(car action-pair) (car action-pair)
(cdr action-pair))) (cdr action-pair)))
`(("Choose an action" . ,(choose-an-action show-sessions)) `(("Choose an action" . ,(choose-an-action show-sessions))
@ -301,7 +301,7 @@
,footer))) ,footer)))
(let ((actions (let ((actions
(map (lambda (action-pair) (map (lambda (action-pair)
(make-annotated-sel-if-option (make-annotated-select-option
(car action-pair) (car action-pair)
(cdr action-pair))) (cdr action-pair)))
`(("Choose an action" . `(("Choose an action" .

5
scheme/httpd/surflets/web-server/root/surflets/byte-input.scm
View File

@ -7,8 +7,6 @@
scheme-with-scsh) scheme-with-scsh)
(begin (begin
;; This doesn't use c-a-l-l-b-a-c-k-s anymore.
(define (make-byte-input-fields bits) (define (make-byte-input-fields bits)
(let ((checkboxes (let ((checkboxes
(reverse (reverse
@ -17,9 +15,10 @@
(if (= count bits) (if (= count bits)
'() '()
(cons (cons
(make-annotated-checkbox-input-field order) (make-annotated-checkbox order)
(loop (+ 1 count) (loop (+ 1 count)
(* 2 order)))))))) (* 2 order))))))))
(make-multi-input-field (make-multi-input-field
#f "byte-input" #f "byte-input"
(lambda (input-field bindings) (lambda (input-field bindings)

10
scheme/httpd/surflets/web-server/root/surflets/calculate-cb.scm
View File

@ -43,15 +43,15 @@
)) ))
(define (make-number-input-field/default default) (define (make-number-field/default default)
(if default (if default
(make-number-input-field `(@ (value ,default))) (make-number-field `(@ (value ,default)))
(make-number-input-field))) (make-number-field)))
(define (show-page operator-pair number1 number2 . maybe-update-text) (define (show-page operator-pair number1 number2 . maybe-update-text)
(let* ((update-text (:optional maybe-update-text "")) (let* ((update-text (:optional maybe-update-text ""))
(number-field1 (make-number-input-field/default number1)) (number-field1 (make-number-field/default number1))
(number-field2 (make-number-input-field/default number2)) (number-field2 (make-number-field/default number2))
(req (req
(send-html/suspend (send-html/suspend
(lambda (new-url) (lambda (new-url)

10
scheme/httpd/surflets/web-server/root/surflets/calculate.scm
View File

@ -35,15 +35,15 @@
*operator-alist*)))))) *operator-alist*))))))
(define (make-number-input-field/default default) (define (make-number-field/default default)
(if default (if default
(make-number-input-field default) (make-number-field default)
(make-number-input-field))) (make-number-field)))
(define (show-page operator-pair number1 number2 . maybe-update-text) (define (show-page operator-pair number1 number2 . maybe-update-text)
(let* ((update-text (:optional maybe-update-text "")) (let* ((update-text (:optional maybe-update-text ""))
(number-field1 (make-number-input-field/default number1)) (number-field1 (make-number-field/default number1))
(number-field2 (make-number-input-field/default number2)) (number-field2 (make-number-field/default number2))
(calculate-button (make-submit-button "Calculate")) (calculate-button (make-submit-button "Calculate"))
(change-button (make-submit-button "Change operator")) (change-button (make-submit-button "Change operator"))
(req (req

22
scheme/httpd/surflets/web-server/root/surflets/spaceship.scm
View File

@ -109,12 +109,12 @@
(def-armed? #f) (def-armed? #f)
(def-shields? #f) (def-shields? #f)
(def-drive #f)) (def-drive #f))
(let* ((class-radios (make-radio-input-fields (let* ((class-radios (make-radios
(checked-radio classes def-class))) (checked-radio classes def-class)))
(drive-radios (make-radio-input-fields (drive-radios (make-radios
(checked-radio drives def-drive))) (checked-radio drives def-drive)))
(armed-checkbox (make-checkbox-input-field def-armed?)) (armed-checkbox (make-checkbox def-armed?))
(shield-checkbox (make-checkbox-input-field def-shields?)) (shield-checkbox (make-checkbox def-shields?))
(req (send-html/suspend (req (send-html/suspend
(lambda (new-url) (lambda (new-url)
(generate-main-page new-url update-text (generate-main-page new-url update-text
@ -163,19 +163,19 @@
(and armed? (and armed?
(map (lambda (type) (map (lambda (type)
(let ((text (cdr (assoc type arm-types)))) (let ((text (cdr (assoc type arm-types))))
(cons (make-annotated-checkbox-input-field (cons (make-annotated-checkbox
text text
(and def-weapons (member? text def-weapons))) (and def-weapons (member? text def-weapons)))
text))) text)))
(ship-data-arm-types (ship-ref class))))) (ship-data-arm-types (ship-ref class)))))
(energy-input (and armed? (energy-input (and armed?
(if def-energy (if def-energy
(make-number-input-field def-energy) (make-number-field def-energy)
(make-number-input-field)))) (make-number-field))))
(shield-input (and shields? (shield-input (and shields?
(if def-shield (if def-shield
(make-number-input-field def-shield) (make-number-field def-shield)
(make-number-input-field)))) (make-number-field))))
(req (send-html/suspend (req (send-html/suspend
(lambda (new-url) (lambda (new-url)
(generate-armed+shield-page new-url update-text (generate-armed+shield-page new-url update-text
@ -215,7 +215,7 @@
;;; items are taken from the ship data list. ;;; items are taken from the ship data list.
(define (get-extras req class) (define (get-extras req class)
(let* ((checkboxes+text (map (lambda (extra) (let* ((checkboxes+text (map (lambda (extra)
(cons (make-annotated-checkbox-input-field extra) (cons (make-annotated-checkbox extra)
(cdr (assoc extra extras)))) (cdr (assoc extra extras))))
(ship-data-extras (ship-ref class)))) (ship-data-extras (ship-ref class))))
(req (send-html/suspend (req (send-html/suspend
@ -269,7 +269,7 @@
;;; and the maximum crew member for a class is not exceeded. ;;; and the maximum crew member for a class is not exceeded.
(define (get-size req class . maybe-update-text) (define (get-size req class . maybe-update-text)
(let* ((update-text (:optional maybe-update-text #f)) (let* ((update-text (:optional maybe-update-text #f))
(size-input (make-number-input-field)) (size-input (make-number-field))
(req (send-html/suspend (req (send-html/suspend
(lambda (new-url) (lambda (new-url)
(generate-size-page new-url update-text (generate-size-page new-url update-text

42
scheme/httpd/surflets/web-server/root/surflets/test.scm
View File

@ -14,23 +14,23 @@
(define selections (cons '("a" "b" "c") (define selections (cons '("a" "b" "c")
'("Andreas" "Bernd" "Clara"))) '("Andreas" "Bernd" "Clara")))
(define radio-elements '(1 2 3 "a" *)) (define radio-elements '(1 2 3 "a" *))
(define select (make-annotated-select-input-field (define select (make-annotated-select
(map make-annotated-sel-if-option (map make-annotated-select-option
(car selections) (car selections)
(cdr selections)) (cdr selections))
#t '(@ (size 2)))) #t '(@ (size 2))))
(define select2 (make-select-input-field (car selections))) (define select2 (make-select (car selections)))
(define text (make-text-input-field "yoho")) (define text (make-text-field "yoho"))
(define number (make-number-input-field 23)) (define number (make-number-field 23))
(define hidden (make-hidden-input-field "value")) (define hidden (make-hidden-field "value"))
(define password (make-password-input-field "asdf")) (define password (make-password-field "asdf"))
(define textarea (make-textarea-input-field "This (define textarea (make-textarea "This
is is
a a
test")) test"))
(define radio (make-annotated-radio-input-field-group)) (define radio (make-annotated-radio-group))
(define radios (map radio radio-elements)) (define radios (map radio radio-elements))
(define checkbox (make-annotated-checkbox-input-field "hooray!")) (define checkbox (make-annotated-checkbox "hooray!"))
(define submit (make-submit-button)) (define submit (make-submit-button))
(define image (make-image-button "/img/221.gif")) (define image (make-image-button "/img/221.gif"))
@ -124,26 +124,26 @@ test"))
(lambda (string) (lambda (string)
(format #f "returned via annotated string ~s" string))) (format #f "returned via annotated string ~s" string)))
(else (else
(set-text-input-field-value! text text-entered) (set-text-field-value! text text-entered)
(only-select-selected! select selected (cdr selections)) (only-select-selected! select selected (cdr selections))
(only-select-selected! select2 (list selected2) (car selections)) (only-select-selected! select2 (list selected2) (car selections))
(if number-entered (if number-entered
(set-number-input-field-value! number number-entered)) (set-number-field-value! number number-entered))
(set-hidden-input-field-value! (set-hidden-field-value!
hidden hidden
(string-append "value" (number->string global))) (string-append "value" (number->string global)))
(set-password-input-field-value! password password-text) (set-password-field-value! password password-text)
(set-textarea-input-field-value! textarea textarea-text) (set-textarea-value! textarea textarea-text)
(if radio-result (if radio-result
(begin (begin
(map uncheck-radio-input-field! radios) (map uncheck-radio! radios)
(check-radio-input-field! (check-radio!
(list-ref radios (list-ref radios
(list-index (lambda (a) (equal? a radio-result)) (list-index (lambda (a) (equal? a radio-result))
radio-elements))))) radio-elements)))))
(if checkbox-result (if checkbox-result
(check-checkbox-input-field! checkbox) (check-checkbox! checkbox)
(uncheck-checkbox-input-field! checkbox)) (uncheck-checkbox! checkbox))
`(p ,(cond `(p ,(cond
(image-result (format #f "Returned via image ~s" image-result)) (image-result (format #f "Returned via image ~s" image-result))
(submit-result "Returned via submit") (submit-result "Returned via submit")
@ -189,10 +189,10 @@ test"))
(define (only-select-selected! sel-if selected indices) (define (only-select-selected! sel-if selected indices)
(for-each (lambda (index) (for-each (lambda (index)
(unselect-sel-if-option! index sel-if)) (unselect-select-option! index sel-if))
(iota (length (cdr selections)))) (iota (length (cdr selections))))
(for-each (lambda (selected) (for-each (lambda (selected)
(select-sel-if-option! (select-select-option!
(list-index (lambda (s) (string=? s selected)) (list-index (lambda (s) (string=? s selected))
indices) indices)
sel-if)) sel-if))