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

add INPUT-FIELD-BINDING

This commit is contained in:
interp 2002-10-02 18:22:01 +00:00
parent d56d7f9fce
commit 74acc71447
2 changed files with 32 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -157,6 +157,7 @@
make-reset-button make-reset-button
make-image-button make-image-button
input-field-value input-field-value
input-field-binding
make-callback)) make-callback))
(define-structure servlets servlets-interface (define-structure servlets servlets-interface

67
scheme/httpd/surflets/surflets.scm
View File

@ -230,11 +230,11 @@
;; PRED-LIST contains list of predicates that recognizes optional ;; PRED-LIST contains list of predicates that recognizes optional
;; leading parameters. FURTHER-ATTRIBUTES is the optional parameter ;; leading parameters. FURTHER-ATTRIBUTES is the optional parameter
;; list as got by procedure call. PREFIX-OPTIONALS returns two values: ;; list as got by procedure call. TYPED-OPTIONALS returns two values:
;; a list of the same length as PRED-LIST and a list containing the ;; a list of the same length as PRED-LIST and a list containing the
;; left arguments that did not fit the predicates. ;; left arguments that did not fit the predicates.
;; ;;
;; With the help of PREFIX-OPTIONALS you can define a function ;; With the help of TYPED-OPTIONALS you can define a function
;; like `make-submit-button [string] [further-attributes]' this way: ;; like `make-submit-button [string] [further-attributes]' this way:
;; (define (make-submit-button . args) ;; (define (make-submit-button . args)
;; (receive (params rest-args) ;; (receive (params rest-args)
@ -319,16 +319,16 @@
(or (string->number string) (or (string->number string)
(error "wrong type"))) (error "wrong type")))
)) ))
(lambda maybe-further-attributes) (lambda maybe-further-attributes
(let ((name (generate-input-field-name "number"))) (let ((name (generate-input-field-name "number")))
(optionals maybe-further-attributes (optionals maybe-further-attributes
((attributes XML-attribute?)) ((attributes XML-attribute?))
(make-input-field (make-input-field
name name
number-input-field-transformer number-input-field-transformer
`(input (@ (type "text") `(input (@ (type "text")
(name ,name) (name ,name)
,(and attributes (cdr attributes)))))))) ,(and attributes (cdr attributes))))))))))
(define (make-password-input-field . maybe-further-attributes) (define (make-password-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "password"))) (let ((name (generate-input-field-name "password")))
@ -438,10 +438,13 @@
(value ,value) (value ,value)
,(and attributes (cdr attributes)))))))) ,(and attributes (cdr attributes))))))))
(define (make-button type button-caption attributes) (define (make-button type name button-caption attributes)
`(input (@ (type ,type) (make-input-field name
,(and button-caption `(value ,button-caption)) identity
,(and attributes (cdr attributes))))) `(input (@ (type ,type)
(name ,name)
,(and button-caption `(value ,button-caption))
,(and attributes (cdr attributes))))))
(define (string-or-symbol? a) (define (string-or-symbol? a)
(or (string? a) (or (string? a)
@ -451,44 +454,36 @@
(optionals maybe-further-attributes (optionals maybe-further-attributes
((button-caption string-or-symbol?) ((button-caption string-or-symbol?)
(attributes XML-attribute?)) (attributes XML-attribute?))
(make-button "submit" button-caption attributes))) (make-button "submit" (generate-input-field-name "submit")
button-caption attributes)))
(define (make-reset-button . maybe-further-attributes) (define (make-reset-button . maybe-further-attributes)
(optionals maybe-further-attributes (optionals maybe-further-attributes
((button-caption string-or-symbol?) ((button-caption string-or-symbol?)
(attributes XML-attribute?)) (attributes XML-attribute?))
(make-button "reset" button-caption attributes))) (make-button "reset" (generate-input-field-name "reset")
button-caption attributes)))
(define (make-image-button image-source . maybe-further-attributes) (define (make-image-button image-source . maybe-further-attributes)
(optionals maybe-further-attributes (optionals maybe-further-attributes
((attributes XML-attribute?)) ((attributes XML-attribute?))
(make-button "image" #f `(@ (src ,image-source) (make-button "image" (generate-input-field-name "imgbtn")
,@(if attributes (cdr attributes) '()))))) #f `(@ (src ,image-source)
,@(if attributes (cdr attributes) '())))))
(define (input-field-value input-field bindings) (define (input-field-value input-field bindings)
(let ((input-field (cadr input-field))) (let ((input-field (cadr input-field)))
(cond (cond
((input-field-get-bindings? input-field) ((input-field-get-bindings? input-field)
((input-field-transformer input-field) bindings)) ((input-field-transformer input-field) bindings))
((assoc (input-field-name input-field) bindings) => ((real-input-field-binding input-field bindings) =>
(lambda (binding) (lambda (binding)
((input-field-transformer input-field) (cdr binding)))) ((input-field-transformer input-field) (cdr binding))))
(else (else
(error "no such input-field" input-field bindings))))) (error "no such input-field" input-field bindings)))))
(define (real-input-field-binding input-field bindings)
(assoc (input-field-name input-field) bindings))
(define (input-field-binding input-field bindings)
(real-input-field-binding (cadr input-field) bindings))
;;; tests
(define number-input-field (make-number-input-field))
(define test
`(html
(title "My Title")
(body
(p (URL "reset" "click here to reset"))
(p (form "return-URI" (table (tr (td "Enter a number ") (td ,number-input-field )))
,(make-submit-button))))))