Remove image button bug (thanks to Eric Knauel for reporting this): Image
buttons return the coordinates where the user clicked la imgbtn321.x=13&imgbtn321.y=12. Thus, we cannot search for the input-field-name of the image button. To remove this bug, we introduce following changes: surflet-input-fields.scm: + make-image-button returns a multi-input-field that searches for its coordinates in the bindings, returning a pair (x y) of it (numbers). + Adapt select-input-fields to interface changes of multi-input-fields: transformers get also their input-fields. returned-via.scm: Don't simply check for the input field name in the binding. Use input-field-value to check for existance of the input field in the bindings input-fields.scm: multi-input-fields get also their input-field as argument web-server/root/surflets/byte-input.scm: Adapt to interface change of multi-input-fields: transformers get also their input-field web-server/root/surflets/test.scm: Check the image-button feature correctly.
This commit is contained in:
interp
parent
69ea6ae13f
commit
6c99e3a707
|
|
@ -135,7 +135,7 @@
|
|||
(let ((real-input-field (cadr input-field)))
|
||||
(cond
|
||||
((real-input-field-multi? real-input-field)
|
||||
((real-input-field-transformer real-input-field) bindings))
|
||||
((real-input-field-transformer real-input-field) input-field bindings))
|
||||
((real-input-field-binding real-input-field bindings) =>
|
||||
(lambda (binding)
|
||||
((real-input-field-transformer real-input-field) (cdr binding))))
|
||||
|
|
@ -162,6 +162,9 @@
|
|||
(define (real-input-field-binding input-field bindings)
|
||||
(assoc (real-input-field-name input-field) bindings))
|
||||
|
||||
;; Returns the binding of the input-field in bindings by the
|
||||
;; input-field's name. If your input-field will have another name in
|
||||
;; the bindings than it was created with, use a multi-input-field.
|
||||
(define (input-field-binding input-field bindings)
|
||||
(real-input-field-binding (cadr input-field) bindings))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(define (returned-via return-object bindings)
|
||||
(if (input-field? return-object)
|
||||
(input-field-binding return-object bindings)
|
||||
(input-field-value return-object bindings)
|
||||
;; We assume we have a return-address-object instead.
|
||||
(let ((address (return-object 'address)))
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -149,8 +149,12 @@
|
|||
;;; 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 in HTML seperated,
|
||||
;;; too.
|
||||
;;; 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?
|
||||
|
|
@ -177,7 +181,7 @@
|
|||
(optionals maybe-attributes
|
||||
((selected? boolean?)
|
||||
(attributes sxml-attribute?))
|
||||
(make-sel-if-option tag 'ignored selected? attributes)))
|
||||
(make-sel-if-option tag tag selected? attributes)))
|
||||
|
||||
(define-record-discloser :sel-if-option
|
||||
(lambda (sel-if-option)
|
||||
|
|
@ -196,6 +200,36 @@
|
|||
(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!
|
||||
|
|
@ -217,34 +251,6 @@
|
|||
(delete tag sel-if-options tag=sel-if-option?))))
|
||||
(touch-input-field! sel-if)))
|
||||
|
||||
(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)
|
||||
(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)
|
||||
(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)))
|
||||
|
||||
;; 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
|
||||
|
|
@ -257,14 +263,13 @@
|
|||
|
||||
(define (make-select-input-field sel-if-options . maybe-further-attributes)
|
||||
(really-make-select-input-field (tolerate-old-sel-if-options sel-if-options)
|
||||
#f
|
||||
maybe-further-attributes))
|
||||
|
||||
(define (make-annotated-select-input-field sel-if-options .
|
||||
maybe-further-attributes)
|
||||
(really-make-select-input-field sel-if-options #t maybe-further-attributes))
|
||||
(really-make-select-input-field sel-if-options maybe-further-attributes))
|
||||
|
||||
(define (really-make-select-input-field sel-if-options annotated?
|
||||
(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
|
||||
|
|
@ -272,17 +277,14 @@
|
|||
(attributes sxml-attribute?))
|
||||
(let ((name (generate-input-field-name "select")))
|
||||
(if multiple?
|
||||
(make-multiple-select-input-field name sel-if-options
|
||||
annotated? attributes)
|
||||
(make-multiple-select-input-field name sel-if-options attributes)
|
||||
(make-single-select-input-field name sel-if-options
|
||||
annotated? attributes))))))
|
||||
attributes))))))
|
||||
|
||||
;; internal
|
||||
(define (make-multiple-select-input-field name sel-if-options
|
||||
annotated? attributes)
|
||||
(define (make-multiple-select-input-field name sel-if-options attributes)
|
||||
(make-multi-input-field name "mult-select"
|
||||
(make-sel-if-multiple-transformer name sel-if-options
|
||||
annotated?)
|
||||
sel-if-multiple-transformer
|
||||
(make-input-field-attributes
|
||||
sel-if-options
|
||||
(list '(multiple)
|
||||
|
|
@ -290,33 +292,27 @@
|
|||
make-sel-if-html-tree))
|
||||
|
||||
;; internal
|
||||
(define (make-single-select-input-field name sel-if-options
|
||||
annotated? attributes)
|
||||
(define (make-single-select-input-field name sel-if-options attributes)
|
||||
(make-input-field name "select"
|
||||
(if annotated?
|
||||
(lambda (tag)
|
||||
(cond ((find-sel-if-option-value tag sel-if-options)
|
||||
=> identity)
|
||||
(else (error "no such option." tag))))
|
||||
identity)
|
||||
(make-input-field-attributes
|
||||
sel-if-options
|
||||
(sxml-attribute-attributes attributes))
|
||||
make-sel-if-html-tree))
|
||||
|
||||
(define (make-sel-if-multiple-transformer name sel-if-options annotated?)
|
||||
(lambda (bindings)
|
||||
(let ((tags (map cdr
|
||||
(filter (lambda (binding)
|
||||
(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))))
|
||||
(filter-map (if annotated?
|
||||
(lambda (tag)
|
||||
bindings))
|
||||
(tags (map cdr my-bindings)))
|
||||
(filter-map (lambda (tag)
|
||||
(find-sel-if-option-value tag sel-if-options))
|
||||
(lambda (tag)
|
||||
(if (find-sel-if-option tag sel-if-options)
|
||||
tag
|
||||
#f)))
|
||||
tags))))
|
||||
|
||||
(define (make-sel-if-html-tree sel-if)
|
||||
|
|
@ -496,6 +492,30 @@
|
|||
#f `(@ (src ,image-source)
|
||||
,@(sxml-attribute-attributes attributes)))))
|
||||
|
||||
(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)))
|
||||
|
||||
(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")))
|
||||
(and x y (cons (string->number x)
|
||||
(string->number 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
|
||||
|
|
@ -22,7 +22,7 @@
|
|||
(* 2 order))))))))
|
||||
(make-multi-input-field
|
||||
#f "byte-input"
|
||||
(lambda (bindings)
|
||||
(lambda (input-field bindings)
|
||||
(let loop ((sum 0)
|
||||
(checkboxes checkboxes))
|
||||
(if (null? checkboxes)
|
||||
|
|
|
|||
|
|
@ -32,6 +32,10 @@ test"))
|
|||
(define radios (map radio radio-elements))
|
||||
(define checkbox (make-annotated-checkbox-input-field "hooray!"))
|
||||
|
||||
(define submit (make-submit-button))
|
||||
(define image (make-image-button "/img/221.gif"))
|
||||
(define reset (make-reset-button))
|
||||
|
||||
(define (translate-line-breaks text)
|
||||
(let lp ((result '())
|
||||
(text text))
|
||||
|
|
@ -65,7 +69,7 @@ test"))
|
|||
(p "called " ,global " times")
|
||||
(p "Choose an annotated address:" (br)
|
||||
(ul
|
||||
(li (url ,(addr new-url "Eva Gottwald") "ab=ba"))
|
||||
(li (url ,(addr new-url "Zoe") "ab=ba"))
|
||||
(li (url ,(addr new-url "be<ta") "be<ta"))
|
||||
(li (url ,(addr new-url) "<nothing>"))))
|
||||
(p "Or choose an annotated callback" (br)
|
||||
|
|
@ -93,8 +97,7 @@ test"))
|
|||
'(nbsp) '(nbsp)))
|
||||
radio-elements))))
|
||||
(tr (td "Checkbox:") (td ,checkbox)))
|
||||
,(make-submit-button) ,(make-reset-button) (br)
|
||||
,(make-image-button "/img/221.gif")))
|
||||
,submit ,reset (br) ,image))
|
||||
(hr)
|
||||
(p (url "/" "Return to main menu.")))))))
|
||||
(bindings (get-bindings req))
|
||||
|
|
@ -107,6 +110,9 @@ test"))
|
|||
(textarea-text (input-field-value textarea bindings))
|
||||
(radio-result (input-field-value (radio #f) bindings))
|
||||
(checkbox-result (input-field-value checkbox bindings))
|
||||
(submit-result (returned-via? submit bindings))
|
||||
(reset-result (returned-via? reset bindings))
|
||||
(image-result (returned-via image bindings))
|
||||
(result
|
||||
(cond
|
||||
((returned-via? addr bindings) =>
|
||||
|
|
@ -114,7 +120,9 @@ test"))
|
|||
(format #f "returned via annotated string ~s" string)))
|
||||
(else
|
||||
(set-text-input-field-value! text text-entered)
|
||||
(format #t "passed1 ")
|
||||
(only-select-selected! select selected (cdr selections))
|
||||
(format #t "passed2 ")
|
||||
(only-select-selected! select2 (list selected2) (car selections))
|
||||
(if number-entered
|
||||
(set-number-input-field-value! number number-entered))
|
||||
|
|
@ -133,7 +141,10 @@ test"))
|
|||
(if checkbox-result
|
||||
(check-checkbox-input-field! checkbox)
|
||||
(uncheck-checkbox-input-field! checkbox))
|
||||
`(p "Returned via submit" (br)
|
||||
`(p ,(cond
|
||||
(image-result (format #f "Returned via image ~s" image-result))
|
||||
(submit-result "Returned via submit")
|
||||
(else "Don't know how you did return.")) (br)
|
||||
"Bindings were: " ,(format #f "~s" bindings) (br)
|
||||
(table
|
||||
(@ (valign "top"))
|
||||
|
|
@ -151,7 +162,6 @@ test"))
|
|||
(tr (td "Radio:") (td ,(format #f "~s" radio-result)))
|
||||
(tr (td "Checkbox:") (td ,(format #f "~s" checkbox-result)))))
|
||||
))))
|
||||
|
||||
(set! global (+ 1 global))
|
||||
(send-html/suspend
|
||||
(lambda (continue)
|
||||
|
|
@ -175,9 +185,11 @@ test"))
|
|||
(url "/" "Return to main menu.")))))))
|
||||
|
||||
(define (only-select-selected! sel-if selected indices)
|
||||
(format #t "called only-select-selected! with ~s ~s ~s~%" sel-if selected indices)
|
||||
(for-each (lambda (index)
|
||||
(unselect-sel-if-option! index sel-if))
|
||||
(iota (length (cdr selections))))
|
||||
(format #t "passeed 3 ")
|
||||
(for-each (lambda (selected)
|
||||
(select-sel-if-option!
|
||||
(list-index (lambda (s) (string=? s selected))
|
||||
|
|
|
|||
Loading…
Reference in New Issue