canvas.test
上传用户:rrhhcc
上传日期:2015-12-11
资源大小:54129k
文件大小:17k
源码类别:

通讯编程

开发平台:

Visual C++

  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: canvas.test,v 1.16 2003/02/09 07:48:22 hobbs Exp $
  10. package require tcltest 2.1
  11. namespace import -force tcltest::configure
  12. namespace import -force tcltest::testsDirectory
  13. configure -testdir [file join [pwd] [file dirname [info script]]]
  14. configure -loadfile [file join [testsDirectory] constraints.tcl]
  15. tcltest::loadTestedCommands
  16. # XXX - This test file is woefully incomplete.  At present, only a
  17. # few of the features are tested.
  18. canvas .c
  19. pack .c
  20. update
  21. set i 1
  22. foreach test {
  23.     {-background #ff0000 #ff0000 non-existent
  24.     {unknown color name "non-existent"}}
  25.     {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}
  26.     {-bd 4 4 badValue {bad screen distance "badValue"}}
  27.     {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
  28.     {-closeenough 24 24.0 bogus {expected floating-point number but got "bogus"}}
  29.     {-confine true 1 silly {expected boolean value but got "silly"}}
  30.     {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
  31.     {-height 2.1 2 x42 {bad screen distance "x42"}}
  32.     {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
  33.     {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}}
  34.     {-highlightthickness 18 18 badValue {bad screen distance "badValue"}}
  35.     {-insertbackground #110022 #110022 bogus {unknown color name "bogus"}}
  36.     {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}}
  37.     {-insertofftime 100 100 3.2 {expected integer but got "3.2"}}
  38.     {-insertontime 100 100 3.2 {expected integer but got "3.2"}}
  39.     {-insertwidth 1.3 1 6x {bad screen distance "6x"}}
  40.     {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
  41.     {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}}
  42.     {-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}}
  43.     {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}}
  44.     {-takefocus "any string" "any string" {} {}}
  45.     {-width 402 402 xyz {bad screen distance "xyz"}}
  46.     {-xscrollcommand {Some command} {Some command} {} {}}
  47.     {-yscrollcommand {Another command} {Another command} {} {}}
  48. } {
  49.     set name [lindex $test 0]
  50.     test canvas-1.$i {configuration options} {
  51. .c configure $name [lindex $test 1]
  52. lindex [.c configure $name] 4
  53.     } [lindex $test 2]
  54.     incr i
  55.     if {[lindex $test 3] != ""} {
  56. test canvas-1.$i {configuration options} {
  57.     list [catch {.c configure $name [lindex $test 3]} msg] $msg
  58. } [list 1 [lindex $test 4]]
  59.     }
  60.     .c configure $name [lindex [.c configure $name] 3]
  61.     incr i
  62. }
  63. test canvas-1.40 {configure throws error on bad option} {
  64.     set res [list [catch {.c configure -gorp foo}]]
  65.     .c create rect 10 10 100 100
  66.     lappend res [catch {.c configure -gorp foo}]
  67.     set res
  68. } [list 1 1]
  69. catch {destroy .c}
  70. canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 
  71. -highlightthickness 0
  72. pack .c
  73. update
  74. test canvas-2.1 {CanvasWidgetCmd, bind option} {
  75.     set i [.c create rect 10 10 100 100]
  76.     list [catch {.c bind $i <a>} msg] $msg
  77. } {0 {}}
  78. test canvas-2.2 {CanvasWidgetCmd, bind option} {
  79.     set i [.c create rect 10 10 100 100]
  80.     list [catch {.c bind $i <} msg] $msg
  81. } {1 {no event type or button # or keysym}}
  82. test canvas-2.3 {CanvasWidgetCmd, xview option} {
  83.     .c configure -xscrollincrement 40 -yscrollincrement 5
  84.     .c xview moveto 0
  85.     update
  86.     set x [list [.c xview]]
  87.     .c xview scroll 2 units
  88.     update
  89.     lappend x [.c xview]
  90. } {{0 0.3} {0.4 0.7}}
  91. test canvas-2.4 {CanvasWidgetCmd, xview option} {nonPortable} {
  92.     # This test gives slightly different results on platforms such
  93.     # as NetBSD.  I don't know why...
  94.     .c configure -xscrollincrement 0 -yscrollincrement 5
  95.     .c xview moveto 0.6
  96.     update
  97.     set x [list [.c xview]]
  98.     .c xview scroll 2 units
  99.     update
  100.     lappend x [.c xview]
  101. } {{0.6 0.9} {0.66 0.96}}
  102. catch {destroy .c}
  103. canvas .c -width 60 -height 40 -scrollregion {0 0 200 80} 
  104. -borderwidth 0 -highlightthickness 0
  105. pack .c
  106. update
  107. test canvas-3.1 {CanvasWidgetCmd, yview option} {
  108.     .c configure -xscrollincrement 40 -yscrollincrement 5
  109.     .c yview moveto 0
  110.     update
  111.     set x [list [.c yview]]
  112.     .c yview scroll 3 units
  113.     update
  114.     lappend x [.c yview]
  115. } {{0 0.5} {0.1875 0.6875}}
  116. test canvas-3.2 {CanvasWidgetCmd, yview option} {
  117.     .c configure -xscrollincrement 40 -yscrollincrement 0
  118.     .c yview moveto 0
  119.     update
  120.     set x [list [.c yview]]
  121.     .c yview scroll 2 units
  122.     update
  123.     lappend x [.c yview]
  124. } {{0 0.5} {0.1 0.6}}
  125. test canvas-4.1 {ButtonEventProc procedure} {
  126.     deleteWindows
  127.     canvas .c1 -bg #543210
  128.     rename .c1 .c2
  129.     set x {}
  130.     lappend x [winfo children .]
  131.     lappend x [.c2 cget -bg]
  132.     destroy .c1
  133.     lappend x [info command .c*] [winfo children .]
  134. } {.c1 #543210 {} {}}
  135. test canvas-5.1 {ButtonCmdDeletedProc procedure} {
  136.     deleteWindows
  137.     canvas .c1
  138.     rename .c1 {}
  139.     list [info command .c*] [winfo children .]
  140. } {{} {}}
  141. catch {destroy .c}
  142. canvas .c -width 100 -height 50 -scrollregion {-200 -100 305 102} 
  143. -borderwidth 2 -highlightthickness 3
  144. pack .c
  145. update
  146. test canvas-6.1 {CanvasSetOrigin procedure} {
  147.     .c configure -xscrollincrement 0 -yscrollincrement 0
  148.     .c xview moveto 0
  149.     .c yview moveto 0
  150.     update
  151.     list [.c canvasx 0] [.c canvasy 0]
  152. } {-205.0 -105.0}
  153. test canvas-6.2 {CanvasSetOrigin procedure} {
  154.     .c configure -xscrollincrement 20 -yscrollincrement 10
  155.     set x ""
  156.     foreach i {.08 .10 .48 .50} {
  157. .c xview moveto $i
  158. update
  159. lappend x [.c canvasx 0]
  160.     }
  161.     set x
  162. } {-165.0 -145.0 35.0 55.0}
  163. test canvas-6.3 {CanvasSetOrigin procedure} {
  164.     .c configure -xscrollincrement 20 -yscrollincrement 10
  165.     set x ""
  166.     foreach i {.06 .08 .70 .72} {
  167. .c yview moveto $i
  168. update
  169. lappend x [.c canvasy 0]
  170.     }
  171.     set x
  172. } {-95.0 -85.0 35.0 45.0}
  173. test canvas-6.4 {CanvasSetOrigin procedure} {
  174.     .c configure -xscrollincrement 20 -yscrollincrement 10
  175.     .c xview moveto 1.0
  176.     .c canvasx 0
  177. } {215.0}
  178. test canvas-6.5 {CanvasSetOrigin procedure} {
  179.     .c configure -xscrollincrement 20 -yscrollincrement 10
  180.     .c yview moveto 1.0
  181.     .c canvasy 0
  182. } {55.0}
  183. set l [interp hidden]
  184. deleteWindows
  185. test canvas-7.1 {canvas widget vs hidden commands} {
  186.     catch {destroy .c}
  187.     canvas .c
  188.     interp hide {} .c
  189.     destroy .c
  190.     list [winfo children .] [interp hidden]
  191. } [list {} $l]
  192. test canvas-8.1 {canvas arc bbox} {
  193.     catch {destroy .c}
  194.     canvas .c
  195.     .c create arc -100 10 100 210 -start 10 -extent 50 -style arc -tags arc1
  196.     set arcBox [.c bbox arc1]
  197.     .c create arc 100 10 300 210 -start 10 -extent 50 -style chord -tags arc2
  198.     set coordBox [.c bbox arc2]
  199.     .c create arc 300 10 500 210 -start 10 -extent 50 -style pieslice -tags arc3
  200.     set pieBox [.c bbox arc3]
  201.     list $arcBox $coordBox $pieBox
  202. } {{48 21 100 94} {248 21 300 94} {398 21 500 112}}
  203. test canvas-9.1 {canvas id creation and deletion} {
  204.     # With Tk 8.0.4 the ids are now stored in a hash table.  You
  205.     # can use this test as a performance test with older versions
  206.     # by changing the value of size.
  207.     set size 15
  208.     catch {destroy .c}
  209.     set c [canvas .c]
  210.     for {set i 0} {$i < $size} {incr i} {
  211. set x [expr {-10 + 3*$i}]
  212. for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} {
  213.     $c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c 
  214.     -outline black -fill blue -tags rect
  215.     $c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" 
  216.     -anchor center -tags text
  217. }
  218.     }
  219.     # The actual bench mark - this code also exercises all the hash
  220.     # table changes.
  221.     set time [lindex [time {
  222. foreach id [$c find withtag all] {
  223.     $c lower $id
  224.     $c raise $id
  225.     $c find withtag $id
  226.     $c bind <Return> $id {}
  227.     $c delete $id
  228. }
  229.     }] 0]
  230.     set x ""
  231. } {}
  232. test canvas-10.1 {find items using tag expressions} {
  233.       catch {destroy .c}
  234.       canvas .c
  235.       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
  236.       .c create oval 20 60 40 80 -fill yellow -tag [list b a]
  237.       .c create oval 20 100 40 120 -fill green -tag [list c b]
  238.       .c create oval 20 140 40 160 -fill blue -tag [list b]
  239.       .c create oval 20 180 40 200 -fill bisque -tag [list a d e]
  240.       .c create oval 20 220 40 240 -fill bisque -tag b
  241.       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
  242.       set res {}
  243.       lappend res [.c find withtag {!a}]
  244.       lappend res [.c find withtag {b&&c}]
  245.       lappend res [.c find withtag {b||c}]
  246.       lappend res [.c find withtag {a&&!b}]
  247.       lappend res [.c find withtag {!b&&!c}]
  248.       lappend res [.c find withtag {d&&a&&c&&b}]
  249.       lappend res [.c find withtag {b^a}]
  250.       lappend res [.c find withtag {(a&&!b)||(!a&&b)}]
  251.       lappend res [.c find withtag { ( a && ! b ) || ( ! a && b ) }]
  252.       lappend res [.c find withtag {a&&!(c||d)}]
  253.       lappend res [.c find withtag {d&&"tag with spaces"}]
  254.       lappend res [.c find withtag "tag with spaces"]
  255. } {{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}
  256. test canvas-10.2 {check errors from tag expressions} {
  257.       catch {destroy .c}
  258.       canvas .c
  259.       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
  260.       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
  261.       catch {.c find withtag {&&c}} err
  262.       set err
  263. } {Unexpected operator in tag search expression}
  264. test canvas-10.3 {check errors from tag expressions} {
  265.       catch {destroy .c}
  266.       canvas .c
  267.       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
  268.       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
  269.       catch {.c find withtag {!!c}} err
  270.       set err
  271. } {Too many '!' in tag search expression}
  272. test canvas-10.4 {check errors from tag expressions} {
  273.       catch {destroy .c}
  274.       canvas .c
  275.       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
  276.       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
  277.       catch {.c find withtag {b||}} err
  278.       set err
  279. } {Missing tag in tag search expression}
  280. test canvas-10.5 {check errors from tag expressions} {
  281.       catch {destroy .c}
  282.       canvas .c
  283.       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
  284.       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
  285.       catch {.c find withtag {b&&(c||)}} err
  286.       set err
  287. } {Unexpected operator in tag search expression}
  288. test canvas-10.6 {check errors from tag expressions} {
  289.       catch {destroy .c}
  290.       canvas .c
  291.       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
  292.       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
  293.       catch {.c find withtag {d&&""}} err
  294.       set err
  295. } {Null quoted tag string in tag search expression}
  296. test canvas-10.7 {check errors from tag expressions} {
  297.       catch {destroy .c}
  298.       canvas .c
  299.       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
  300.       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
  301.       catch {.c find withtag "d&&"tag with spaces"} err
  302.       set err
  303. } {Missing endquote in tag search expression}
  304. test canvas-10.8 {check errors from tag expressions} {
  305.       catch {destroy .c}
  306.       canvas .c
  307.       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
  308.       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
  309.       catch {.c find withtag {a&&"tag with spaces"z}} err
  310.       set err
  311. } {Invalid boolean operator in tag search expression}
  312. test canvas-10.9 {check errors from tag expressions} {
  313.       catch {destroy .c}
  314.       canvas .c
  315.       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
  316.       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
  317.       catch {.c find withtag {a&&b&c}} err
  318.       set err
  319. } {Singleton '&' in tag search expression}
  320. test canvas-10.10 {check errors from tag expressions} {
  321.       catch {destroy .c}
  322.       canvas .c
  323.       .c create oval 20 20 40 40 -fill red -tag [list a b c d]
  324.       .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
  325.       catch {.c find withtag {a||b|c}} err
  326.       set err
  327. } {Singleton '|' in tag search expression}
  328. test canvas-10.11 {backward compatility - strange tags that are not expressions} {
  329.       catch {destroy .c}
  330.       canvas .c
  331.       .c create oval 20 20 40 40 -fill red -tag [list { strange tag(xxx&yyy|zzz) " && " || ! ^ " }]
  332.       .c find withtag { strange tag(xxx&yyy|zzz) " && " || ! ^ " }
  333. } {1}
  334. test canvas-10.12 {multple events bound to same tag expr} {
  335.       catch {destroy .c}
  336.       canvas .c
  337.       .c bind {a && b} <Enter> {puts Enter}
  338.       .c bind {a && b} <Leave> {puts Leave}
  339. } {}
  340. test canvas-11.1 {canvas poly fill check, bug 5783} {
  341.     # This would crash in 8.3.0 and 8.3.1
  342.     destroy .c
  343.     pack [canvas .c]
  344.     .c create polygon 0 0 100 100 200 50 
  345.     -fill {} -stipple gray50 -outline black
  346. } 1
  347. test canvas-11.2 {canvas poly overlap fill check, bug 226357} {
  348.     destroy .c
  349.     pack [canvas .c]
  350.     set result {}
  351.     .c create poly 30 30 90 90 30 90 90 30
  352.     lappend result [.c find over 40 40 45 45]; # rect region inc. edge
  353.     lappend result [.c find over 60 40 60 40]; # top-center point
  354.     lappend result [.c find over 0 0 0 0]; # not on poly
  355.     lappend result [.c find over 60 60 60 60]; # center-point
  356.     lappend result [.c find over 45 50 45 50]; # outside poly
  357.     .c itemconfig 1 -fill "" -outline black
  358.     lappend result [.c find over 40 40 45 45]; # rect region inc. edge
  359.     lappend result [.c find over 60 40 60 40]; # top-center point
  360.     lappend result [.c find over 0 0 0 0]; # not on poly
  361.     lappend result [.c find over 60 60 60 60]; # center-point
  362.     lappend result [.c find over 45 50 45 50]; # outside poly
  363.     .c itemconfig 1 -width 8
  364.     lappend result [.c find over 45 50 45 50]; # outside poly
  365. } {1 1 {} 1 {} 1 1 {} 1 {} 1}
  366. test canvas-12.1 {canvas mm obj, patch SF-403327, 102471} {
  367.     destroy .c
  368.     pack [canvas .c]
  369.     set qx [expr {1.+1.}] 
  370.     # qx has type double and no string representation 
  371.     .c scale all $qx 0 1. 1.
  372.     # qx has now type MMRep and no string representation 
  373.     list $qx [string length $qx]
  374. } {2.0 3}
  375. test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} {
  376.     destroy .c
  377.     pack [canvas .c]
  378.     set val 10
  379.     incr val
  380.     # qx has type double and no string representation 
  381.     .c scale all $val 0 1 1
  382.     # qx has now type MMRep and no string representation 
  383.     incr val
  384. } {12}
  385. proc kill_canvas {w} {
  386.     destroy $w
  387.     pack [canvas $w -height 200 -width 200] -fill both -expand yes
  388.     update idle
  389.     $w create rectangle 80 80 120 120 -fill blue -tags blue
  390.     # bind a button press to re-build the canvas
  391.     $w bind blue <ButtonRelease-1> [subst {
  392. [lindex [info level 0] 0] $w
  393. append ::x ok
  394.     }
  395.     ]
  396. }
  397. test canvas-13.1 {canvas delete during event, SF bug-228024} {
  398.     kill_canvas .c
  399.     set ::x {}
  400.     # do this many times to improve chances of triggering the crash
  401.     for {set i 0} {$i < 30} {incr i} {
  402. event generate .c <1> -x 100 -y 100
  403. event generate .c <ButtonRelease-1> -x 100 -y 100
  404.     }
  405.     set ::x
  406. } okokokokokokokokokokokokokokokokokokokokokokokokokokokokokok
  407. test canvas-14.1 {canvas scan SF bug 581560} {
  408.     destroy .c; canvas .c
  409.     list [catch {.c scan} msg] $msg
  410. } {1 {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}}
  411. test canvas-14.2 {canvas scan} {
  412.     destroy .c; canvas .c
  413.     list [catch {.c scan bogus} msg] $msg
  414. } {1 {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}}
  415. test canvas-14.3 {canvas scan} {
  416.     destroy .c; canvas .c
  417.     list [catch {.c scan mark} msg] $msg
  418. } {1 {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}}
  419. test canvas-14.4 {canvas scan} {
  420.     destroy .c; canvas .c
  421.     list [catch {.c scan mark 10 10} msg] $msg
  422. } {0 {}}
  423. test canvas-14.5 {canvas scan} {
  424.     destroy .c; canvas .c
  425.     list [catch {.c scan mark 10 10 5} msg] $msg
  426. } {1 {wrong # args: should be ".c scan mark x y"}}
  427. test canvas-14.6 {canvas scan} {
  428.     destroy .c; canvas .c
  429.     list [catch {.c scan dragto 10 10 5} msg] $msg
  430. } {0 {}}
  431. set i 0
  432. proc create {w type args} {
  433.     eval [list $w create $type] $args
  434. }
  435. foreach type {arc bitmap image line oval polygon rect text window} {
  436.     test canvas-15.[incr i] "basic types check: $type" {
  437. destroy .c; canvas .c
  438. list [catch {.c create $type} msg] $msg
  439.     } [format {1 {wrong # args: should be ".c create %s coords ?arg arg ...?"}} $type]
  440.     test canvas-15.[incr i] "basic coords check: $type" {
  441. destroy .c; canvas .c
  442. list [catch {.c create $type 0} msg] 
  443. [string match "wrong # coordinates: expected*" $msg]
  444.     } {1 1}
  445. }
  446. test canvas-16.1 {arc coords check} {
  447.     destroy .c; canvas .c
  448.     set id [.c create arc {0 10 20 30} -start 33]
  449.     .c itemcget $id -start
  450. } {33.0}
  451. destroy .c
  452. # cleanup
  453. ::tcltest::cleanupTests
  454. return