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:
parent
69ea6ae13f
commit
6c99e3a707
|
@ -135,7 +135,7 @@
|
||||||
(let ((real-input-field (cadr input-field)))
|
(let ((real-input-field (cadr input-field)))
|
||||||
(cond
|
(cond
|
||||||
((real-input-field-multi? real-input-field)
|
((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) =>
|
((real-input-field-binding real-input-field bindings) =>
|
||||||
(lambda (binding)
|
(lambda (binding)
|
||||||
((real-input-field-transformer real-input-field) (cdr binding))))
|
((real-input-field-transformer real-input-field) (cdr binding))))
|
||||||
|
@ -162,6 +162,9 @@
|
||||||
(define (real-input-field-binding input-field bindings)
|
(define (real-input-field-binding input-field bindings)
|
||||||
(assoc (real-input-field-name 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)
|
(define (input-field-binding input-field bindings)
|
||||||
(real-input-field-binding (cadr input-field) bindings))
|
(real-input-field-binding (cadr input-field) bindings))
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
|
|
||||||
(define (returned-via return-object bindings)
|
(define (returned-via return-object bindings)
|
||||||
(if (input-field? return-object)
|
(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.
|
;; We assume we have a return-address-object instead.
|
||||||
(let ((address (return-object 'address)))
|
(let ((address (return-object 'address)))
|
||||||
(cond
|
(cond
|
||||||
|
|
|
@ -149,8 +149,12 @@
|
||||||
;;; A selection input field shows a list of options that can be
|
;;; A selection 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 sel-if-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 in HTML seperated,
|
;;; justified by the fact, that the options list is seperated in HTML,
|
||||||
;;; too.
|
;;; 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
|
(define-record-type sel-if-option :sel-if-option
|
||||||
(really-make-sel-if-option tag value selected? attributes)
|
(really-make-sel-if-option tag value selected? attributes)
|
||||||
sel-if-option?
|
sel-if-option?
|
||||||
|
@ -177,7 +181,7 @@
|
||||||
(optionals maybe-attributes
|
(optionals maybe-attributes
|
||||||
((selected? boolean?)
|
((selected? boolean?)
|
||||||
(attributes sxml-attribute?))
|
(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
|
(define-record-discloser :sel-if-option
|
||||||
(lambda (sel-if-option)
|
(lambda (sel-if-option)
|
||||||
|
@ -196,6 +200,36 @@
|
||||||
(define (unselect-sel-if-option! tag sel-if)
|
(define (unselect-sel-if-option! tag sel-if)
|
||||||
(set-select-input-field-option-selected?! tag sel-if #f))
|
(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)
|
(define (add-sel-if-option! sel-if sel-if-option)
|
||||||
(let ((attributes (input-field-attributes sel-if)))
|
(let ((attributes (input-field-attributes sel-if)))
|
||||||
(set-input-field-attributes-default!
|
(set-input-field-attributes-default!
|
||||||
|
@ -217,34 +251,6 @@
|
||||||
(delete tag sel-if-options tag=sel-if-option?))))
|
(delete tag sel-if-options tag=sel-if-option?))))
|
||||||
(touch-input-field! sel-if)))
|
(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,
|
;; 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 sel-if-options-list (easily createable with
|
||||||
|
@ -257,14 +263,13 @@
|
||||||
|
|
||||||
(define (make-select-input-field sel-if-options . maybe-further-attributes)
|
(define (make-select-input-field sel-if-options . maybe-further-attributes)
|
||||||
(really-make-select-input-field (tolerate-old-sel-if-options sel-if-options)
|
(really-make-select-input-field (tolerate-old-sel-if-options sel-if-options)
|
||||||
#f
|
|
||||||
maybe-further-attributes))
|
maybe-further-attributes))
|
||||||
|
|
||||||
(define (make-annotated-select-input-field sel-if-options .
|
(define (make-annotated-select-input-field sel-if-options .
|
||||||
maybe-further-attributes)
|
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)
|
maybe-further-attributes)
|
||||||
(let ((real-sel-if-options (tolerate-old-sel-if-options sel-if-options)))
|
(let ((real-sel-if-options (tolerate-old-sel-if-options sel-if-options)))
|
||||||
(optionals maybe-further-attributes
|
(optionals maybe-further-attributes
|
||||||
|
@ -272,17 +277,14 @@
|
||||||
(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
|
(make-multiple-select-input-field name sel-if-options attributes)
|
||||||
annotated? attributes)
|
|
||||||
(make-single-select-input-field name sel-if-options
|
(make-single-select-input-field name sel-if-options
|
||||||
annotated? attributes))))))
|
attributes))))))
|
||||||
|
|
||||||
;; internal
|
;; internal
|
||||||
(define (make-multiple-select-input-field name sel-if-options
|
(define (make-multiple-select-input-field name sel-if-options attributes)
|
||||||
annotated? attributes)
|
|
||||||
(make-multi-input-field name "mult-select"
|
(make-multi-input-field name "mult-select"
|
||||||
(make-sel-if-multiple-transformer name sel-if-options
|
sel-if-multiple-transformer
|
||||||
annotated?)
|
|
||||||
(make-input-field-attributes
|
(make-input-field-attributes
|
||||||
sel-if-options
|
sel-if-options
|
||||||
(list '(multiple)
|
(list '(multiple)
|
||||||
|
@ -290,33 +292,27 @@
|
||||||
make-sel-if-html-tree))
|
make-sel-if-html-tree))
|
||||||
|
|
||||||
;; internal
|
;; internal
|
||||||
(define (make-single-select-input-field name sel-if-options
|
(define (make-single-select-input-field name sel-if-options attributes)
|
||||||
annotated? attributes)
|
|
||||||
(make-input-field name "select"
|
(make-input-field name "select"
|
||||||
(if annotated?
|
(lambda (tag)
|
||||||
(lambda (tag)
|
(cond ((find-sel-if-option-value tag sel-if-options)
|
||||||
(cond ((find-sel-if-option-value tag sel-if-options)
|
=> identity)
|
||||||
=> identity)
|
(else (error "no such option." tag))))
|
||||||
(else (error "no such option." tag))))
|
|
||||||
identity)
|
|
||||||
(make-input-field-attributes
|
(make-input-field-attributes
|
||||||
sel-if-options
|
sel-if-options
|
||||||
(sxml-attribute-attributes attributes))
|
(sxml-attribute-attributes attributes))
|
||||||
make-sel-if-html-tree))
|
make-sel-if-html-tree))
|
||||||
|
|
||||||
(define (make-sel-if-multiple-transformer name sel-if-options annotated?)
|
(define (sel-if-multiple-transformer input-field bindings)
|
||||||
(lambda (bindings)
|
(let ((name (input-field-name input-field))
|
||||||
(let ((tags (map cdr
|
(sel-if-options (input-field-attributes-default
|
||||||
(filter (lambda (binding)
|
(input-field-attributes input-field))))
|
||||||
|
(let* ((my-bindings (filter (lambda (binding)
|
||||||
(equal? (car binding) name))
|
(equal? (car binding) name))
|
||||||
bindings))))
|
bindings))
|
||||||
(filter-map (if annotated?
|
(tags (map cdr my-bindings)))
|
||||||
(lambda (tag)
|
(filter-map (lambda (tag)
|
||||||
(find-sel-if-option-value tag sel-if-options))
|
(find-sel-if-option-value tag sel-if-options))
|
||||||
(lambda (tag)
|
|
||||||
(if (find-sel-if-option tag sel-if-options)
|
|
||||||
tag
|
|
||||||
#f)))
|
|
||||||
tags))))
|
tags))))
|
||||||
|
|
||||||
(define (make-sel-if-html-tree sel-if)
|
(define (make-sel-if-html-tree sel-if)
|
||||||
|
@ -496,6 +492,30 @@
|
||||||
#f `(@ (src ,image-source)
|
#f `(@ (src ,image-source)
|
||||||
,@(sxml-attribute-attributes attributes)))))
|
,@(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
|
;;EOF
|
|
@ -22,7 +22,7 @@
|
||||||
(* 2 order))))))))
|
(* 2 order))))))))
|
||||||
(make-multi-input-field
|
(make-multi-input-field
|
||||||
#f "byte-input"
|
#f "byte-input"
|
||||||
(lambda (bindings)
|
(lambda (input-field bindings)
|
||||||
(let loop ((sum 0)
|
(let loop ((sum 0)
|
||||||
(checkboxes checkboxes))
|
(checkboxes checkboxes))
|
||||||
(if (null? checkboxes)
|
(if (null? checkboxes)
|
||||||
|
|
|
@ -32,6 +32,10 @@ test"))
|
||||||
(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-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)
|
(define (translate-line-breaks text)
|
||||||
(let lp ((result '())
|
(let lp ((result '())
|
||||||
(text text))
|
(text text))
|
||||||
|
@ -65,7 +69,7 @@ test"))
|
||||||
(p "called " ,global " times")
|
(p "called " ,global " times")
|
||||||
(p "Choose an annotated address:" (br)
|
(p "Choose an annotated address:" (br)
|
||||||
(ul
|
(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 "be<ta") "be<ta"))
|
||||||
(li (url ,(addr new-url) "<nothing>"))))
|
(li (url ,(addr new-url) "<nothing>"))))
|
||||||
(p "Or choose an annotated callback" (br)
|
(p "Or choose an annotated callback" (br)
|
||||||
|
@ -93,8 +97,7 @@ test"))
|
||||||
'(nbsp) '(nbsp)))
|
'(nbsp) '(nbsp)))
|
||||||
radio-elements))))
|
radio-elements))))
|
||||||
(tr (td "Checkbox:") (td ,checkbox)))
|
(tr (td "Checkbox:") (td ,checkbox)))
|
||||||
,(make-submit-button) ,(make-reset-button) (br)
|
,submit ,reset (br) ,image))
|
||||||
,(make-image-button "/img/221.gif")))
|
|
||||||
(hr)
|
(hr)
|
||||||
(p (url "/" "Return to main menu.")))))))
|
(p (url "/" "Return to main menu.")))))))
|
||||||
(bindings (get-bindings req))
|
(bindings (get-bindings req))
|
||||||
|
@ -107,6 +110,9 @@ test"))
|
||||||
(textarea-text (input-field-value textarea bindings))
|
(textarea-text (input-field-value textarea bindings))
|
||||||
(radio-result (input-field-value (radio #f) bindings))
|
(radio-result (input-field-value (radio #f) bindings))
|
||||||
(checkbox-result (input-field-value checkbox 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
|
(result
|
||||||
(cond
|
(cond
|
||||||
((returned-via? addr bindings) =>
|
((returned-via? addr bindings) =>
|
||||||
|
@ -114,7 +120,9 @@ test"))
|
||||||
(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-input-field-value! text text-entered)
|
||||||
|
(format #t "passed1 ")
|
||||||
(only-select-selected! select selected (cdr selections))
|
(only-select-selected! select selected (cdr selections))
|
||||||
|
(format #t "passed2 ")
|
||||||
(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-input-field-value! number number-entered))
|
||||||
|
@ -133,7 +141,10 @@ test"))
|
||||||
(if checkbox-result
|
(if checkbox-result
|
||||||
(check-checkbox-input-field! checkbox)
|
(check-checkbox-input-field! checkbox)
|
||||||
(uncheck-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)
|
"Bindings were: " ,(format #f "~s" bindings) (br)
|
||||||
(table
|
(table
|
||||||
(@ (valign "top"))
|
(@ (valign "top"))
|
||||||
|
@ -151,7 +162,6 @@ test"))
|
||||||
(tr (td "Radio:") (td ,(format #f "~s" radio-result)))
|
(tr (td "Radio:") (td ,(format #f "~s" radio-result)))
|
||||||
(tr (td "Checkbox:") (td ,(format #f "~s" checkbox-result)))))
|
(tr (td "Checkbox:") (td ,(format #f "~s" checkbox-result)))))
|
||||||
))))
|
))))
|
||||||
|
|
||||||
(set! global (+ 1 global))
|
(set! global (+ 1 global))
|
||||||
(send-html/suspend
|
(send-html/suspend
|
||||||
(lambda (continue)
|
(lambda (continue)
|
||||||
|
@ -175,9 +185,11 @@ test"))
|
||||||
(url "/" "Return to main menu.")))))))
|
(url "/" "Return to main menu.")))))))
|
||||||
|
|
||||||
(define (only-select-selected! sel-if selected indices)
|
(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)
|
(for-each (lambda (index)
|
||||||
(unselect-sel-if-option! index sel-if))
|
(unselect-sel-if-option! index sel-if))
|
||||||
(iota (length (cdr selections))))
|
(iota (length (cdr selections))))
|
||||||
|
(format #t "passeed 3 ")
|
||||||
(for-each (lambda (selected)
|
(for-each (lambda (selected)
|
||||||
(select-sel-if-option!
|
(select-sel-if-option!
|
||||||
(list-index (lambda (s) (string=? s selected))
|
(list-index (lambda (s) (string=? s selected))
|
||||||
|
|
Loading…
Reference in New Issue