From 6c99e3a7078b6997a27f189a51039fb05b34d8ef Mon Sep 17 00:00:00 2001 From: interp Date: Thu, 22 May 2003 13:32:49 +0000 Subject: [PATCH] =?UTF-8?q?Remove=20image=20button=20bug=20(thanks=20to=20?= =?UTF-8?q?Eric=20Knauel=20for=20reporting=20this):=20Image=20buttons=20re?= =?UTF-8?q?turn=20the=20coordinates=20where=20the=20user=20clicked=20=E0?= =?UTF-8?q?=20la=20imgbtn321.x=3D13&imgbtn321.y=3D12.=20Thus,=20we=20canno?= =?UTF-8?q?t=20search=20for=20the=20input-field-name=20of=20the=20image=20?= =?UTF-8?q?button.=20To=20remove=20this=20bug,=20we=20introduce=20followin?= =?UTF-8?q?g=20changes:?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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. --- scheme/httpd/surflets/input-fields.scm | 5 +- scheme/httpd/surflets/returned-via.scm | 2 +- .../httpd/surflets/surflet-input-fields.scm | 142 ++++++++++-------- .../web-server/root/surflets/byte-input.scm | 2 +- .../web-server/root/surflets/test.scm | 22 ++- 5 files changed, 104 insertions(+), 69 deletions(-) diff --git a/scheme/httpd/surflets/input-fields.scm b/scheme/httpd/surflets/input-fields.scm index 3d1c864..ddb1268 100644 --- a/scheme/httpd/surflets/input-fields.scm +++ b/scheme/httpd/surflets/input-fields.scm @@ -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)) diff --git a/scheme/httpd/surflets/returned-via.scm b/scheme/httpd/surflets/returned-via.scm index 49e44fd..e0f3a6d 100644 --- a/scheme/httpd/surflets/returned-via.scm +++ b/scheme/httpd/surflets/returned-via.scm @@ -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 diff --git a/scheme/httpd/surflets/surflet-input-fields.scm b/scheme/httpd/surflets/surflet-input-fields.scm index d2f27cb..c5c4cd4 100644 --- a/scheme/httpd/surflets/surflet-input-fields.scm +++ b/scheme/httpd/surflets/surflet-input-fields.scm @@ -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! @@ -216,34 +250,6 @@ attributes (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 @@ -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) + (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 (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) - (find-sel-if-option-value tag sel-if-options)) - (lambda (tag) - (if (find-sel-if-option tag sel-if-options) - tag - #f))) + 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) @@ -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 \ No newline at end of file diff --git a/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm b/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm index f1881ae..ddfd453 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm @@ -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) diff --git a/scheme/httpd/surflets/web-server/root/surflets/test.scm b/scheme/httpd/surflets/web-server/root/surflets/test.scm index fdf5f55..62aee93 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/test.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/test.scm @@ -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")))) (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))