tk/tests/canvas.test

   1 # This file is a Tcl script to test out the procedures in tkCanvas.c,
   2 # which implements generic code for canvases.  It is organized in the
   3 # standard fashion for Tcl tests.
   4 #
   5 # Copyright (c) 1995-1996 Sun Microsystems, Inc.
   6 # Copyright (c) 1998-2000 Ajuba Solutions.
   7 # All rights reserved.
   8 #
   9 # RCS: @(#) $Id$
  10
  11 if {[lsearch [namespace children] ::tcltest] == -1} {
  12     source [file join [pwd] [file dirname [info script]] defs.tcl]
  13 }
  14
  15 foreach i [winfo children .] {
  16     destroy $i
  17 }
  18 wm geometry . {}
  19 raise .
  20
  21 # XXX - This test file is woefully incomplete.  At present, only a
  22 # few of the features are tested.
  23
  24 canvas .c
  25 pack .c
  26 update
  27 set i 1
  28 foreach test {
  29     {-background #ff0000 #ff0000 non-existent
  30             {unknown color name "non-existent"}}
  31     {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}
  32     {-bd 4 4 badValue {bad screen distance "badValue"}}
  33     {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
  34     {-closeenough 24 24.0 bogus {expected floating-point number but got "bogus"}}
  35     {-confine true 1 silly {expected boolean value but got "silly"}}
  36     {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
  37     {-height 2.1 2 x42 {bad screen distance "x42"}}
  38     {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
  39     {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}}
  40     {-highlightthickness 18 18 badValue {bad screen distance "badValue"}}
  41     {-insertbackground #110022 #110022 bogus {unknown color name "bogus"}}
  42     {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}}
  43     {-insertofftime 100 100 3.2 {expected integer but got "3.2"}}
  44     {-insertontime 100 100 3.2 {expected integer but got "3.2"}}
  45     {-insertwidth 1.3 1 6x {bad screen distance "6x"}}
  46     {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
  47     {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}}
  48     {-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}}
  49     {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}}
  50     {-takefocus "any string" "any string" {} {}}
  51     {-width 402 402 xyz {bad screen distance "xyz"}}
  52     {-xscrollcommand {Some command} {Some command} {} {}}
  53     {-yscrollcommand {Another command} {Another command} {} {}}
  54 } {
  55     set name [lindex $test 0]
  56     test canvas-1.$i {configuration options} {
  57         .c configure $name [lindex $test 1]
  58         lindex [.c configure $name] 4
  59     } [lindex $test 2]
  60     incr i
  61     if {[lindex $test 3] != ""} {
  62         test canvas-1.$i {configuration options} {
  63             list [catch {.c configure $name [lindex $test 3]} msg] $msg
  64         } [list 1 [lindex $test 4]]
  65     }
  66     .c configure $name [lindex [.c configure $name] 3]
  67     incr i
  68 }
  69
  70 test canvas-1.40 {configure throws error on bad option} {
  71     set res [list [catch {.c configure -gorp foo}]]
  72     .c create rect 10 10 100 100
  73     lappend res [catch {.c configure -gorp foo}]
  74     set res
  75 } [list 1 1]
  76
  77
  78 catch {destroy .c}
  79 canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \
  80         -highlightthickness 0
  81 pack .c
  82 update
  83
  84 test canvas-2.1 {CanvasWidgetCmd, bind option} {
  85     set i [.c create rect 10 10 100 100]
  86     list [catch {.c bind $i <a>} msg] $msg
  87 } {0 {}}
  88 test canvas-2.2 {CanvasWidgetCmd, bind option} {
  89     set i [.c create rect 10 10 100 100]
  90     list [catch {.c bind $i <} msg] $msg
  91 } {1 {no event type or button # or keysym}}
  92 test canvas-2.3 {CanvasWidgetCmd, xview option} {
  93     .c configure -xscrollincrement 40 -yscrollincrement 5
  94     .c xview moveto 0
  95     update
  96     set x [list [.c xview]]
  97     .c xview scroll 2 units
  98     update
  99     lappend x [.c xview]
 100 } {{0 0.3} {0.4 0.7}}
 101 test canvas-2.4 {CanvasWidgetCmd, xview option} {nonPortable} {
 102     # This test gives slightly different results on platforms such
 103     # as NetBSD.  I don't know why...
 104     .c configure -xscrollincrement 0 -yscrollincrement 5
 105     .c xview moveto 0.6
 106     update
 107     set x [list [.c xview]]
 108     .c xview scroll 2 units
 109     update
 110     lappend x [.c xview]
 111 } {{0.6 0.9} {0.66 0.96}}
 112
 113 catch {destroy .c}
 114 canvas .c -width 60 -height 40 -scrollregion {0 0 200 80} \
 115         -borderwidth 0 -highlightthickness 0
 116 pack .c
 117 update
 118 test canvas-3.1 {CanvasWidgetCmd, yview option} {
 119     .c configure -xscrollincrement 40 -yscrollincrement 5
 120     .c yview moveto 0
 121     update
 122     set x [list [.c yview]]
 123     .c yview scroll 3 units
 124     update
 125     lappend x [.c yview]
 126 } {{0 0.5} {0.1875 0.6875}}
 127 test canvas-3.2 {CanvasWidgetCmd, yview option} {
 128     .c configure -xscrollincrement 40 -yscrollincrement 0
 129     .c yview moveto 0
 130     update
 131     set x [list [.c yview]]
 132     .c yview scroll 2 units
 133     update
 134     lappend x [.c yview]
 135 } {{0 0.5} {0.1 0.6}}
 136
 137 test canvas-4.1 {ButtonEventProc procedure} {
 138     eval destroy [winfo children .]
 139     canvas .c1 -bg #543210
 140     rename .c1 .c2
 141     set x {}
 142     lappend x [winfo children .]
 143     lappend x [.c2 cget -bg]
 144     destroy .c1
 145     lappend x [info command .c*] [winfo children .]
 146 } {.c1 #543210 {} {}}
 147
 148 test canvas-5.1 {ButtonCmdDeletedProc procedure} {
 149     eval destroy [winfo children .]
 150     canvas .c1
 151     rename .c1 {}
 152     list [info command .c*] [winfo children .]
 153 } {{} {}}
 154
 155 catch {destroy .c}
 156 canvas .c -width 100 -height 50 -scrollregion {-200 -100 305 102} \
 157         -borderwidth 2 -highlightthickness 3
 158 pack .c
 159 update
 160 test canvas-6.1 {CanvasSetOrigin procedure} {
 161     .c configure -xscrollincrement 0 -yscrollincrement 0
 162     .c xview moveto 0
 163     .c yview moveto 0
 164     update
 165     list [.c canvasx 0] [.c canvasy 0]
 166 } {-205.0 -105.0}
 167 test canvas-6.2 {CanvasSetOrigin procedure} {
 168     .c configure -xscrollincrement 20 -yscrollincrement 10
 169     set x ""
 170     foreach i {.08 .10 .48 .50} {
 171         .c xview moveto $i
 172         update
 173         lappend x [.c canvasx 0]
 174     }
 175     set x
 176 } {-165.0 -145.0 35.0 55.0}
 177 test canvas-6.3 {CanvasSetOrigin procedure} {
 178     .c configure -xscrollincrement 20 -yscrollincrement 10
 179     set x ""
 180     foreach i {.06 .08 .70 .72} {
 181         .c yview moveto $i
 182         update
 183         lappend x [.c canvasy 0]
 184     }
 185     set x
 186 } {-95.0 -85.0 35.0 45.0}
 187 test canvas-6.4 {CanvasSetOrigin procedure} {
 188     .c configure -xscrollincrement 20 -yscrollincrement 10
 189     .c xview moveto 1.0
 190     .c canvasx 0
 191 } {215.0}
 192 test canvas-6.5 {CanvasSetOrigin procedure} {
 193     .c configure -xscrollincrement 20 -yscrollincrement 10
 194     .c yview moveto 1.0
 195     .c canvasy 0
 196 } {55.0}
 197
 198 set l [interp hidden]
 199 eval destroy [winfo children .]
 200
 201 test canvas-7.1 {canvas widget vs hidden commands} {
 202     catch {destroy .c}
 203     canvas .c
 204     interp hide {} .c
 205     destroy .c
 206     list [winfo children .] [interp hidden]
 207 } [list {} $l]
 208
 209 test canvas-8.1 {canvas arc bbox} {
 210     catch {destroy .c}
 211     canvas .c
 212     .c create arc -100 10 100 210 -start 10 -extent 50 -style arc -tags arc1
 213     set arcBox [.c bbox arc1]
 214     .c create arc 100 10 300 210 -start 10 -extent 50 -style chord -tags arc2
 215     set coordBox [.c bbox arc2]
 216     .c create arc 300 10 500 210 -start 10 -extent 50 -style pieslice -tags arc3
 217     set pieBox [.c bbox arc3]
 218     list $arcBox $coordBox $pieBox
 219 } {{48 21 100 94} {248 21 300 94} {398 21 500 112}}
 220 test canvas-9.1 {canvas id creation and deletion} {
 221     # With Tk 8.0.4 the ids are now stored in a hash table.  You
 222     # can use this test as a performance test with older versions
 223     # by changing the value of size.
 224     set size 15
 225
 226     catch {destroy .c}
 227     set c [canvas .c]
 228     for {set i 0} {$i < $size} {incr i} {
 229         set x [expr {-10 + 3*$i}]
 230         for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} {
 231             $c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \
 232                     -outline black -fill blue -tags rect
 233             $c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \
 234                     -anchor center -tags text
 235         }
 236     }
 237
 238     # The actual bench mark - this code also exercises all the hash
 239     # table changes.
 240
 241     set time [lindex [time {
 242         foreach id [$c find withtag all] {
 243             $c lower $id
 244             $c raise $id
 245             $c find withtag $id
 246             $c bind <Return> $id {}
 247             $c delete $id
 248         }
 249     }] 0]
 250
 251     set x ""
 252 } {}
 253 test canvas-10.1 {find items using tag expressions} {
 254       catch {destroy .c}
 255       canvas .c
 256       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
 257       .c create oval 20 60 40 80 -fill yellow -tag [list b a]
 258       .c create oval 20 100 40 120 -fill green -tag [list c b]
 259       .c create oval 20 140 40 160 -fill blue -tag [list b]
 260       .c create oval 20 180 40 200 -fill bisque -tag [list a d e]
 261       .c create oval 20 220 40 240 -fill bisque -tag b
 262       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
 263       set res {}
 264       lappend res [.c find withtag {!a}]
 265       lappend res [.c find withtag {b&&c}]
 266       lappend res [.c find withtag {b||c}]
 267       lappend res [.c find withtag {a&&!b}]
 268       lappend res [.c find withtag {!b&&!c}]
 269       lappend res [.c find withtag {d&&a&&c&&b}]
 270       lappend res [.c find withtag {b^a}]
 271       lappend res [.c find withtag {(a&&!b)||(!a&&b)}]
 272       lappend res [.c find withtag { ( a && ! b ) || ( ! a && b ) }]
 273       lappend res [.c find withtag {a&&!(c||d)}]
 274       lappend res [.c find withtag {d&&"tag with spaces"}]
 275       lappend res [.c find withtag "tag with spaces"]
 276 } {{3 4 6 7} {1 3} {1 2 3 4 6} 5 {5 7} 1 {3 4 5 6} {3 4 5 6} {3 4 5 6} 2 7 7}
 277 test canvas-10.2 {check errors from tag expressions} {
 278       catch {destroy .c}
 279       canvas .c
 280       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
 281       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
 282       catch {.c find withtag {&&c}} err
 283       set err
 284 } {Unexpected operator in tag search expression}
 285 test canvas-10.3 {check errors from tag expressions} {
 286       catch {destroy .c}
 287       canvas .c
 288       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
 289       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
 290       catch {.c find withtag {!!c}} err
 291       set err
 292 } {Too many '!' in tag search expression}
 293 test canvas-10.4 {check errors from tag expressions} {
 294       catch {destroy .c}
 295       canvas .c
 296       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
 297       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
 298       catch {.c find withtag {b||}} err
 299       set err
 300 } {Missing tag in tag search expression}
 301 test canvas-10.5 {check errors from tag expressions} {
 302       catch {destroy .c}
 303       canvas .c
 304       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
 305       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
 306       catch {.c find withtag {b&&(c||)}} err
 307       set err
 308 } {Unexpected operator in tag search expression}
 309 test canvas-10.6 {check errors from tag expressions} {
 310       catch {destroy .c}
 311       canvas .c
 312       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
 313       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
 314       catch {.c find withtag {d&&""}} err
 315       set err
 316 } {Null quoted tag string in tag search expression}
 317 test canvas-10.7 {check errors from tag expressions} {
 318       catch {destroy .c}
 319       canvas .c
 320       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
 321       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
 322       catch {.c find withtag "d&&\"tag with spaces"} err
 323       set err
 324 } {Missing endquote in tag search expression}
 325 test canvas-10.8 {check errors from tag expressions} {
 326       catch {destroy .c}
 327       canvas .c
 328       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
 329       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
 330       catch {.c find withtag {a&&"tag with spaces"z}} err
 331       set err
 332 } {Invalid boolean operator in tag search expression}
 333 test canvas-10.9 {check errors from tag expressions} {
 334       catch {destroy .c}
 335       canvas .c
 336       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
 337       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
 338       catch {.c find withtag {a&&b&c}} err
 339       set err
 340 } {Singleton '&' in tag search expression}
 341 test canvas-10.10 {check errors from tag expressions} {
 342       catch {destroy .c}
 343       canvas .c
 344       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
 345       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
 346       catch {.c find withtag {a||b|c}} err
 347       set err
 348 } {Singleton '|' in tag search expression}
 349 test canvas-10.11 {backward compatility - strange tags that are not expressions} {
 350       catch {destroy .c}
 351       canvas .c
 352       .c create oval 20 20 40 40 -fill red -tag [list { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }]
 353       .c find withtag { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }
 354 } {1}
 355 test canvas-10.12 {multple events bound to same tag expr} {
 356       catch {destroy .c}
 357       canvas .c
 358       .c bind {a && b} <Enter> {puts Enter}
 359       .c bind {a && b} <Leave> {puts Leave}
 360 } {}
 361
 362 test canvas-11.1 {canvas poly fill check, bug 5783} {
 363     # This would crash in 8.3.0 and 8.3.1
 364     destroy .c
 365     pack [canvas .c]
 366     .c create polygon 0 0 100 100 200 50 \
 367             -fill {} -stipple gray50 -outline black
 368 } 1
 369
 370 # cleanup
 371 ::tcltest::cleanupTests
 372 return
 373