home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tk4.0 / tests / button.test < prev    next >
Encoding:
Text File  |  1995-04-24  |  29.4 KB  |  879 lines
  1. # This file is a Tcl script to test labels, buttons, checkbuttons, and
  2. # radiobuttons in Tk (i.e., all the widgets defined in tkButton.c).  It is
  3. # organized in the standard fashion for Tcl tests.
  4. #
  5. # Copyright (c) 1994 The Regents of the University of California.
  6. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  7. #
  8. # See the file "license.terms" for information on usage and redistribution
  9. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10. #
  11. # @(#) button.test 1.18 95/04/23 16:06:48
  12.  
  13. if {[lsearch [image types] test] < 0} {
  14.     puts "This application hasn't been compiled with the \"test\""
  15.     puts "image, so I can't run this test.  Are you sure you're using"
  16.     puts "tktest instead of wish?"
  17.     return
  18. }
  19.  
  20. if {[info procs test] != "test"} {
  21.     source defs
  22. }
  23.  
  24. foreach i [winfo children .] {
  25.     destroy $i
  26. }
  27. wm geometry . {}
  28. raise .
  29.  
  30. proc bogusTrace args {
  31.     error "trace aborted"
  32. }
  33. catch {unset value}
  34. catch {unset value2}
  35.  
  36. eval image delete [image names]
  37. image create test image1
  38. label .l -text Label
  39. button .b -text Button
  40. checkbutton .c -text Checkbutton
  41. radiobutton .r -text Radiobutton
  42. pack .l .b .c .r
  43. update
  44. set i 1
  45. foreach test {
  46.     {-activebackground #012345 #012345 non-existent
  47.         {unknown color name "non-existent"}}
  48.     {-activeforeground #ff0000 #ff0000 non-existent
  49.         {unknown color name "non-existent"}}
  50.     {-anchor nw nw bogus {bad anchor position "bogus": must be n, ne, e, se, s, sw, w, nw, or center}}
  51.     {-background #ff0000 #ff0000 non-existent
  52.         {unknown color name "non-existent"}}
  53.     {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}
  54.     {-bd 4 4 badValue {bad screen distance "badValue"}}
  55.     {-bitmap questhead questhead badValue {bitmap "badValue" not defined}}
  56.     {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
  57.     {-command "set x" {set x} {} {}}
  58.     {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
  59.     {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}}
  60.     {-fg #110022 #110022 bogus {unknown color name "bogus"}}
  61.     {-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* 
  62.         -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* bogus
  63.         {font "bogus" doesn't exist}}
  64.     {-foreground #110022 #110022 bogus {unknown color name "bogus"}}
  65.     {-height 18 18 20.0 {expected integer but got "20.0"}}
  66.     {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
  67.     {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}}
  68.     {-highlightthickness 18 18 badValue {bad screen distance "badValue"}}
  69.     {-image image1 image1 bogus {image "bogus" doesn't exist}}
  70.     {-indicatoron yes 1 no_way {expected boolean value but got "no_way"}}
  71.     {-justify right right bogus {bad justification "bogus": must be left, right, or center}}
  72.     {-offvalue lousy lousy {} {}}
  73.     {-offvalue fantastic fantastic {} {}}
  74.     {-padx 12 12 420x {bad screen distance "420x"}}
  75.     {-pady 12 12 420x {bad screen distance "420x"}}
  76.     {-relief groove groove 1.5 {bad relief type "1.5":  must be flat, groove, raised, ridge, or sunken}}
  77.     {-selectcolor #110022 #110022 bogus {unknown color name "bogus"}}
  78.     {-selectimage image1 image1 bogus {image "bogus" doesn't exist}}
  79.     {-state normal normal bogus {bad state value "bogus":  must be normal, active, or disabled}}
  80.     {-takefocus "any string" "any string" {} {}}
  81.     {-text "Sample text" {Sample text} {} {}}
  82.     {-textvariable i i {} {}}
  83.     {-underline 5 5 3p {expected integer but got "3p"}}
  84.     {-width 402 402 3p {expected integer but got "3p"}}
  85.     {-wraplength 100 100 6x {bad screen distance "6x"}}
  86. } {
  87.     set name [lindex $test 0]
  88.     test button-1.$i {configuration options} {
  89.     .c configure $name [lindex $test 1]
  90.     lindex [.c configure $name] 4
  91.     } [lindex $test 2]
  92.     incr i
  93.     if {[lindex $test 3] != ""} {
  94.     test button-1.$i {configuration options} {
  95.         list [catch {.c configure $name [lindex $test 3]} msg] $msg
  96.     } [list 1 [lindex $test 4]]
  97.     }
  98.     .c configure $name [lindex [.c configure $name] 3]
  99.     incr i
  100. }
  101.  
  102. set i 1
  103. foreach check {
  104.     {-activebackground 1 0 0 0}
  105.     {-activeforeground 1 0 0 0}
  106.     {-anchor 0 0 0 0}
  107.     {-background 0 0 0 0}
  108.     {-bd 0 0 0 0}
  109.     {-bg 0 0 0 0}
  110.     {-bitmap 0 0 0 0}
  111.     {-borderwidth 0 0 0 0}
  112.     {-command 1 0 0 0}
  113.     {-cursor 0 0 0 0}
  114.     {-disabledforeground 1 0 0 0}
  115.     {-fg 0 0 0 0}
  116.     {-font 0 0 0 0}
  117.     {-foreground 0 0 0 0}
  118.     {-height 0 0 0 0}
  119.     {-image 0 0 0 0}
  120.     {-indicatoron 1 1 0 0}
  121.     {-offvalue 1 1 0 1}
  122.     {-onvalue 1 1 0 1}
  123.     {-padx 0 0 0 0}
  124.     {-pady 0 0 0 0}
  125.     {-relief 0 0 0 0}
  126.     {-selectcolor 1 1 0 0}
  127.     {-selectimage 1 1 0 0}
  128.     {-state 1 0 0 0}
  129.     {-text 0 0 0 0}
  130.     {-textvariable 0 0 0 0}
  131.     {-value 1 1 1 0}
  132.     {-variable 1 1 0 0}
  133.     {-width 0 0 0 0}
  134. } {
  135.     test button-2.$i {label-specific options} "
  136.     catch {.l configure [lindex $check 0]}
  137.     " [lindex $check 1]
  138.     incr i
  139.     test button-2.$i {button-specific options} "
  140.     catch {.b configure [lindex $check 0]}
  141.     " [lindex $check 2]
  142.     incr i
  143.     test button-2.$i {checkbutton-specific options} "
  144.     catch {.c configure [lindex $check 0]}
  145.     " [lindex $check 3]
  146.     incr i
  147.     test button-2.$i {radiobutton-specific options} "
  148.     catch {.r configure [lindex $check 0]}
  149.     " [lindex $check 4]
  150.     incr i
  151. }
  152.  
  153. test button-3.1 {ButtonCreate procedure} {
  154.     list [catch {button} msg] $msg
  155. } {1 {wrong # args:  should be "button pathName ?options?"}}
  156. test button-3.2 {ButtonCreate procedure} {
  157.     catch {destroy .x}
  158.     label .x
  159.     winfo class .x
  160. } {Label}
  161. test button-3.3 {ButtonCreate procedure} {
  162.     catch {destroy .x}
  163.     button .x
  164.     winfo class .x
  165. } {Button}
  166. test button-3.4 {ButtonCreate procedure} {
  167.     catch {destroy .x}
  168.     checkbutton .x
  169.     winfo class .x
  170. } {Checkbutton}
  171. test button-3.5 {ButtonCreate procedure} {
  172.     catch {destroy .x}
  173.     radiobutton .x
  174.     winfo class .x
  175. } {Radiobutton}
  176. rename button gorp
  177. test button-3.6 {ButtonCreate procedure} {
  178.     catch {destroy .x}
  179.     gorp .x
  180.     winfo class .x
  181. } {Button}
  182. rename gorp button
  183. test button-3.7 {ButtonCreate procedure} {
  184.     list [catch {button foo} msg] $msg
  185. } {1 {bad window path name "foo"}}
  186. test button-3.8 {ButtonCreate procedure} {
  187.     catch {destroy .x}
  188.     list [catch {button .x -gorp foo} msg] $msg [winfo exists .x]
  189. } {1 {unknown option "-gorp"} 0}
  190.  
  191. test button-4.1 {ButtonWidgetCmd procedure} {
  192.     list [catch {.b} msg] $msg
  193. } {1 {wrong # args: should be ".b option ?arg arg ...?"}}
  194. test button-4.2 {ButtonWidgetCmd procedure, Tk_Preserve usage} {
  195.     eval image delete [image names]
  196.     image create test image1
  197.     catch {destroy .x}
  198.     button .x -image image1 -command {
  199.     lappend x deleting
  200.     destroy .x
  201.     lappend x [image names]
  202.     }
  203.     image delete image1
  204.     set x {}
  205.     .x invoke
  206.     lappend x [image names]
  207. } {deleting image1 {}}
  208. test button-4.3 {ButtonWidgetCmd procedure, "cget" option} {
  209.     list [catch {.b c} msg] $msg
  210. } {1 {bad option "c":  must be cget, configure, flash, or invoke}}
  211. test button-4.4 {ButtonWidgetCmd procedure, "cget" option} {
  212.     list [catch {.b cget a b} msg] $msg
  213. } {1 {wrong # args: should be ".b cget option"}}
  214. test button-4.5 {ButtonWidgetCmd procedure, "cget" option} {
  215.     list [catch {.b cget -gorp} msg] $msg
  216. } {1 {unknown option "-gorp"}}
  217. test button-4.6 {ButtonWidgetCmd procedure, "cget" option} {
  218.     .b configure -highlightthickness 3
  219.     .b cget -highlightthickness
  220. } {3}
  221. test button-4.7 {ButtonWidgetCmd procedure, "cget" option} {
  222.     list [catch {.l cget -disabledforeground} msg] $msg
  223. } {1 {unknown option "-disabledforeground"}}
  224. test button-4.8 {ButtonWidgetCmd procedure, "cget" option} {
  225.     catch {.b cget -disabledforeground}
  226. } {0}
  227. test button-4.9 {ButtonWidgetCmd procedure, "cget" option} {
  228.     list [catch {.b cget -variable} msg] $msg
  229. } {1 {unknown option "-variable"}}
  230. test button-4.10 {ButtonWidgetCmd procedure, "cget" option} {
  231.     catch {.c cget -variable}
  232. } {0}
  233. test button-4.11 {ButtonWidgetCmd procedure, "cget" option} {
  234.     list [catch {.c cget -value} msg] $msg
  235. } {1 {unknown option "-value"}}
  236. test button-4.12 {ButtonWidgetCmd procedure, "cget" option} {
  237.     catch {.r cget -value}
  238. } {0}
  239. test button-4.13 {ButtonWidgetCmd procedure, "cget" option} {
  240.     list [catch {.r cget -onvalue} msg] $msg
  241. } {1 {unknown option "-onvalue"}}
  242. test button-4.14 {ButtonWidgetCmd procedure, "configure" option} {
  243.     llength [.c configure]
  244. } {36}
  245. test button-4.15 {ButtonWidgetCmd procedure, "configure" option} {
  246.     list [catch {.b configure -gorp} msg] $msg
  247. } {1 {unknown option "-gorp"}}
  248. test button-4.16 {ButtonWidgetCmd procedure, "configure" option} {
  249.     list [catch {.b co -bg #ffffff -fg} msg] $msg
  250. } {1 {value for "-fg" missing}}
  251. test button-4.17 {ButtonWidgetCmd procedure, "configure" option} {
  252.     .b configure -fg #123456
  253.     .b configure -bg #654321
  254.     lindex [.b configure -fg] 4
  255. } {#123456}
  256. .c configure -variable value -onvalue 1 -offvalue 0
  257. .r configure -variable value2 -value red
  258. test button-4.18 {ButtonWidgetCmd procedure, "deselect" option} {
  259.     list [catch {.c deselect foo} msg] $msg
  260. } {1 {wrong # args: should be ".c deselect"}}
  261. test button-4.19 {ButtonWidgetCmd procedure, "deselect" option} {
  262.     list [catch {.l deselect} msg] $msg
  263. } {1 {bad option "deselect":  must be cget or configure}}
  264. test button-4.20 {ButtonWidgetCmd procedure, "deselect" option} {
  265.     list [catch {.b deselect} msg] $msg
  266. } {1 {bad option "deselect":  must be cget, configure, flash, or invoke}}
  267. test button-4.21 {ButtonWidgetCmd procedure, "deselect" option} {
  268.     set value 1
  269.     .c d
  270.     set value
  271. } {0}
  272. test button-4.22 {ButtonWidgetCmd procedure, "deselect" option} {
  273.     set value2 green
  274.     .r deselect
  275.     set value2
  276. } {green}
  277. test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} {
  278.     set value2 red
  279.     .r deselect
  280.     set value2
  281. } {}
  282. test button-4.24 {ButtonWidgetCmd procedure, "deselect" option} {
  283.     set value 1
  284.     trace variable value w bogusTrace
  285.     set result [list [catch {.c deselect} msg] $msg $errorInfo $value]
  286.     trace vdelete value w bogusTrace
  287.     set result
  288. } {1 {can't set "value": trace aborted} {can't set "value": trace aborted
  289.     while executing
  290. ".c deselect"} 0}
  291. test button-4.25 {ButtonWidgetCmd procedure, "deselect" option} {
  292.     set value2 red
  293.     trace variable value2 w bogusTrace
  294.     set result [list [catch {.r deselect} msg] $msg $errorInfo $value2]
  295.     trace vdelete value2 w bogusTrace
  296.     set result
  297. } {1 {can't set "value2": trace aborted} {can't set "value2": trace aborted
  298.     while executing
  299. ".r deselect"} {}}
  300. test button-4.26 {ButtonWidgetCmd procedure, "flash" option} {
  301.     list [catch {.b flash foo} msg] $msg
  302. } {1 {wrong # args: should be ".b flash"}}
  303. test button-4.27 {ButtonWidgetCmd procedure, "flash" option} {
  304.     list [catch {.l flash} msg] $msg
  305. } {1 {bad option "flash":  must be cget or configure}}
  306. test button-4.28 {ButtonWidgetCmd procedure, "flash" option} {
  307.     list [catch {.b flash} msg] $msg
  308. } {0 {}}
  309. test button-4.29 {ButtonWidgetCmd procedure, "flash" option} {
  310.     list [catch {.c flash} msg] $msg
  311. } {0 {}}
  312. test button-4.30 {ButtonWidgetCmd procedure, "flash" option} {
  313.     list [catch {.r f} msg] $msg
  314. } {0 {}}
  315. test button-4.31 {ButtonWidgetCmd procedure, "invoke" option} {
  316.     list [catch {.b invoke foo} msg] $msg
  317. } {1 {wrong # args: should be ".b invoke"}}
  318. test button-4.32 {ButtonWidgetCmd procedure, "invoke" option} {
  319.     list [catch {.l invoke} msg] $msg
  320. } {1 {bad option "invoke":  must be cget or configure}}
  321. test button-4.33 {ButtonWidgetCmd procedure, "invoke" option} {
  322.     .b configure -command {set x invoked}
  323.     set x "not invoked"
  324.     .b invoke
  325.     set x
  326. } {invoked}
  327. test button-4.34 {ButtonWidgetCmd procedure, "invoke" option} {
  328.     .b configure -command {set x invoked} -state disabled
  329.     set x "not invoked"
  330.     .b invoke
  331.     set x
  332. } {not invoked}
  333. test button-4.35 {ButtonWidgetCmd procedure, "invoke" option} {
  334.     set value bogus
  335.     .c configure -command {set x invoked} -variable value -onvalue 1 \
  336.         -offvalue 0
  337.     set x "not invoked"
  338.     .c invoke
  339.     list $x $value
  340. } {invoked 1}
  341. test button-4.36 {ButtonWidgetCmd procedure, "invoke" option} {
  342.     set value2 green
  343.     .r configure -command {set x invoked} -variable value2 -value red
  344.     set x "not invoked"
  345.     .r i
  346.     list $x $value2
  347. } {invoked red}
  348. test button-4.37 {ButtonWidgetCmd procedure, "select" option} {
  349.     list [catch {.l select} msg] $msg
  350. } {1 {bad option "select":  must be cget or configure}}
  351. test button-4.38 {ButtonWidgetCmd procedure, "select" option} {
  352.     list [catch {.b select} msg] $msg
  353. } {1 {bad option "select":  must be cget, configure, flash, or invoke}}
  354. test button-4.39 {ButtonWidgetCmd procedure, "select" option} {
  355.     list [catch {.c select foo} msg] $msg
  356. } {1 {wrong # args: should be ".c select"}}
  357. test button-4.40 {ButtonWidgetCmd procedure, "select" option} {
  358.     set value bogus
  359.     .c configure -command {} -variable value -onvalue lovely -offvalue 0
  360.     .c s
  361.     set value
  362. } {lovely}
  363. test button-4.41 {ButtonWidgetCmd procedure, "select" option} {
  364.     set value2 green
  365.     .r configure -command {} -variable value2 -value red
  366.     .r select
  367.     set value2
  368. } {red}
  369. test button-4.42 {ButtonWidgetCmd procedure, "select" option} {
  370.     set value2 yellow
  371.     trace variable value2 w bogusTrace
  372.     set result [list [catch {.r select} msg] $msg $errorInfo $value2]
  373.     trace vdelete value2 w bogusTrace
  374.     set result
  375. } {1 {can't set "value2": trace aborted} {can't set "value2": trace aborted
  376.     while executing
  377. ".r select"} red}
  378. test button-4.43 {ButtonWidgetCmd procedure, "toggle" option} {
  379.     list [catch {.l toggle} msg] $msg
  380. } {1 {bad option "toggle":  must be cget or configure}}
  381. test button-4.44 {ButtonWidgetCmd procedure, "toggle" option} {
  382.     list [catch {.b toggle} msg] $msg
  383. } {1 {bad option "toggle":  must be cget, configure, flash, or invoke}}
  384. test button-4.45 {ButtonWidgetCmd procedure, "toggle" option} {
  385.     list [catch {.r toggle} msg] $msg
  386. } {1 {bad option "toggle":  must be cget, configure, deselect, flash, invoke, or select}}
  387. test button-4.46 {ButtonWidgetCmd procedure, "toggle" option} {
  388.     list [catch {.c toggle foo} msg] $msg
  389. } {1 {wrong # args: should be ".c toggle"}}
  390. test button-4.47 {ButtonWidgetCmd procedure, "toggle" option} {
  391.     set value bogus
  392.     .c configure -command {} -variable value -onvalue sunshine -offvalue rain
  393.     .c toggle
  394.     set result $value
  395.     .c toggle
  396.     lappend result $value
  397.     .c toggle
  398.     lappend result $value
  399. } {sunshine rain sunshine}
  400. test button-4.48 {ButtonWidgetCmd procedure, "toggle" option} {
  401.     .c configure -onvalue xyz -offvalue abc
  402.     set value xyz
  403.     trace variable value w bogusTrace
  404.     set result [list [catch {.c toggle} msg] $msg $errorInfo $value]
  405.     trace vdelete value w bogusTrace
  406.     set result
  407. } {1 {can't set "value": trace aborted} {can't set "value": trace aborted
  408.     while executing
  409. ".c toggle"} abc}
  410. test button-4.49 {ButtonWidgetCmd procedure, "toggle" option} {
  411.     .c configure -onvalue xyz -offvalue abc
  412.     set value abc
  413.     trace variable value w bogusTrace
  414.     set result [list [catch {.c toggle} msg] $msg $errorInfo $value]
  415.     trace vdelete value w bogusTrace
  416.     set result
  417. } {1 {can't set "value": trace aborted} {can't set "value": trace aborted
  418.     while executing
  419. ".c toggle"} xyz}
  420. test button-4.50 {ButtonWidgetCmd procedure} {
  421.     list [catch {.c bad_option} msg] $msg
  422. } {1 {bad option "bad_option":  must be cget, configure, deselect, flash, invoke, select, or toggle}}
  423.  
  424. test button-5.1 {DestroyButton procedure} {
  425.     image create test image1
  426.     button .b1 -image image1
  427.     button .b2 -fg #ff0000 -text "Button 2"
  428.     button .b3 -state active -text "Button 3"
  429.     button .b4 -disabledforeground #0000ff -state disabled -text "Button 4"
  430.     checkbutton .b5 -variable x -text "Checkbutton 5"
  431.     set x 1
  432.     pack .b1 .b2 .b3 .b4 .b5
  433.     update
  434.     eval destroy [winfo children .]
  435. } {}
  436.  
  437. test button-6.1 {ConfigureButton procedure} {
  438.     catch {destroy .b1}
  439.     set x From-x
  440.     set y From-y
  441.     button .b1 -textvariable x
  442.     .b1 configure -textvariable y
  443.     set x New
  444.     lindex [.b1 configure -text] 4
  445. } {From-y}
  446. test button-6.2 {ConfigureButton procedure} {
  447.     catch {destroy .b1}
  448.     catch {unset x}
  449.     checkbutton .b1 -variable x
  450.     set x 1
  451.     set y 1
  452.     .b1 configure -textvariable y
  453.     set x 0
  454.     .b1 toggle
  455.     set y
  456. } {1}
  457. test button-6.3 {ConfigureButton procedure} {
  458.     catch {destroy .b1}
  459.     eval image delete [image names]
  460.     image create test image1
  461.     image create test image2
  462.     button .b1 -image image1
  463.     image delete image1
  464.     .b1 configure -image image2
  465.     image names
  466. } {image2}
  467. test button-6.4 {ConfigureButton procedure} {
  468.     catch {destroy .b1}
  469.     button .b1 -text "Test" -state disabled
  470.     list [catch {.b1 configure -state bogus} msg] $msg \
  471.         [lindex [.b1 configure -state] 4]
  472. } {1 {bad state value "bogus":  must be normal, active, or disabled} normal}
  473. test button-6.5 {ConfigureButton procedure} {
  474.     catch {destroy .b1}
  475.     checkbutton .b1
  476.     .b1 cget -variable
  477. } {b1}
  478. test button-6.6 {ConfigureButton procedure} {
  479.     catch {destroy .b1}
  480.     set x 0
  481.     set y Shiny
  482.     checkbutton .b1 -variable x
  483.     .b1 configure -variable y -onvalue Shiny
  484.     .b1 toggle
  485.     set y
  486. } 0
  487. test button-6.7 {ConfigureButton procedure} {
  488.     catch {destroy .b1}
  489.     catch {unset x}
  490.     checkbutton .b1 -variable x -offvalue Bogus
  491.     set x
  492. } Bogus
  493. test button-6.8 {ConfigureButton procedure} {
  494.     catch {destroy .b1}
  495.     catch {unset x}
  496.     radiobutton .b1 -variable x
  497.     set x
  498. } {}
  499. test button-6.9 {ConfigureButton procedure} {
  500.     catch {destroy .b1}
  501.     catch {unset x}
  502.     trace variable x w bogusTrace
  503.     set result [list [catch {radiobutton .b1 -variable x} msg] $msg]
  504.     trace vdelete x w bogusTrace
  505.     set result
  506. } {1 {can't set "x": trace aborted}}
  507. test button-6.10 {ConfigureButton procedure} {
  508.     catch {destroy .b1}
  509.     list [catch {button .b1 -image bogus} msg] $msg
  510. } {1 {image "bogus" doesn't exist}}
  511. test button-6.11 {ConfigureButton procedure} {
  512.     catch {destroy .b1}
  513.     catch {unset x}
  514.     button .b1 -textvariable x -text "Button 1"
  515.     set x
  516. } {Button 1}
  517. test button-6.12 {ConfigureButton procedure} {
  518.     catch {destroy .b1}
  519.     set x Override
  520.     button .b1 -textvariable x -text "Button 1"
  521.     set x
  522. } {Override}
  523. test button-6.13 {ConfigureButton procedure} {
  524.     catch {destroy .b1}
  525.     catch {unset x}
  526.     trace variable x w bogusTrace
  527.     set result [list [catch {radiobutton .b1 -text foo -textvariable x} msg] \
  528.         $msg $x]
  529.     trace vdelete x w bogusTrace
  530.     set result
  531. } {1 {can't set "x": trace aborted} foo}
  532. test button-6.14 {ConfigureButton procedure} {
  533.     catch {destroy .b1}
  534.     button .b1 -text "Button 1"
  535.     list [catch {.b1 configure -width 1i} msg] $msg $errorInfo
  536. } {1 {expected integer but got "1i"} {expected integer but got "1i"
  537.     (processing -width option)
  538.     invoked from within
  539. ".b1 configure -width 1i"}}
  540. test button-6.15 {ConfigureButton procedure} {
  541.     catch {destroy .b1}
  542.     button .b1 -text "Button 1"
  543.     list [catch {.b1 configure -height 0.5c} msg] $msg $errorInfo
  544. } {1 {expected integer but got "0.5c"} {expected integer but got "0.5c"
  545.     (processing -height option)
  546.     invoked from within
  547. ".b1 configure -height 0.5c"}}
  548. test button-6.16 {ConfigureButton procedure} {
  549.     catch {destroy .b1}
  550.     button .b1 -bitmap questhead
  551.     list [catch {.b1 configure -width abc} msg] $msg $errorInfo
  552. } {1 {bad screen distance "abc"} {bad screen distance "abc"
  553.     (processing -width option)
  554.     invoked from within
  555. ".b1 configure -width abc"}}
  556. test button-6.17 {ConfigureButton procedure} {
  557.     catch {destroy .b1}
  558.     eval image delete [image names]
  559.     image create test image1
  560.     button .b1 -image image1
  561.     list [catch {.b1 configure -height 0.5x} msg] $msg $errorInfo
  562. } {1 {bad screen distance "0.5x"} {bad screen distance "0.5x"
  563.     (processing -height option)
  564.     invoked from within
  565. ".b1 configure -height 0.5x"}}
  566. if $doNonPortableTests {
  567.     test button-6.18 {ConfigureButton procedure} {
  568.     catch {destroy .b1}
  569.     button .b1 -text "Sample text" -width 10 -height 2
  570.     pack .b1
  571.     set result "[winfo reqwidth .b1] [winfo reqheight .b1]"
  572.     .b1 configure -bitmap questhead
  573.     lappend result [winfo reqwidth .b1] [winfo reqheight .b1]
  574.     } {102 48 20 12}
  575. }
  576. test button-6.19 {ConfigureButton procedure} {
  577.     catch {destroy .b1}
  578.     button .b1 -text "Button 1"
  579.     set old [winfo reqwidth .b1]
  580.     .b1 configure -text "Much longer text"
  581.     set new [winfo reqwidth .b1]
  582.     expr $old == $new
  583. } {0}
  584.  
  585. test button-7.1 {ButtonEventProc procedure} {
  586.     catch {destroy .b1}
  587.     button .b1 -text "Test Button" -command {
  588.     destroy .b1
  589.     set x [list [winfo exists .b1] [info commands .b1]]
  590.     }
  591.     .b1 invoke
  592.     set x
  593. } {0 {}}
  594. test button-7.2 {ButtonEventProc procedure} {
  595.     eval destroy [winfo children .]
  596.     button .b1 -bg #543210
  597.     rename .b1 .b2
  598.     set x {}
  599.     lappend x [winfo children .]
  600.     lappend x [.b2 cget -bg]
  601.     destroy .b1
  602.     lappend x [info command .b*] [winfo children .]
  603. } {.b1 #543210 {} {}}
  604.  
  605. test button-8.1 {ButtonCmdDeletedProc procedure} {
  606.     eval destroy [winfo children .]
  607.     button .b1
  608.     rename .b1 {}
  609.     list [info command .b*] [winfo children .]
  610. } {{} {}}
  611.  
  612. test button-9.1 {ComputeButtonGeometry procedure} {
  613.     eval destroy [winfo children .]
  614.     image create test image1
  615.     image1 changed 0 0 0 0 60 40
  616.     label .b1 -image image1 -bd 4 -padx 0 -pady 2
  617.     button .b2 -image image1 -bd 4 -padx 0 -pady 2
  618.     checkbutton .b3 -image image1 -bd 4 -padx 1 -pady 1
  619.     radiobutton .b4 -image image1 -bd 4 -padx 2 -pady 0
  620.     pack .b1 .b2 .b3 .b4
  621.     update
  622.     list [winfo reqwidth .b1] [winfo reqheight .b1] \
  623.         [winfo reqwidth .b2] [winfo reqheight .b2] \
  624.         [winfo reqwidth .b3] [winfo reqheight .b3] \
  625.         [winfo reqwidth .b4] [winfo reqheight .b4]
  626. } {68 48 74 54 112 52 112 52}
  627. test button-9.2 {ComputeButtonGeometry procedure} {
  628.     eval destroy [winfo children .]
  629.     label .b1 -bitmap question -bd 3 -padx 0 -pady 2
  630.     button .b2 -bitmap question -bd 3 -padx 0 -pady 2
  631.     checkbutton .b3 -bitmap question -bd 3 -padx 1 -pady 1
  632.     radiobutton .b4 -bitmap question -bd 3 -padx 2 -pady 0
  633.     pack .b1 .b2 .b3 .b4
  634.     update
  635.     list [winfo reqwidth .b1] [winfo reqheight .b1] \
  636.         [winfo reqwidth .b2] [winfo reqheight .b2] \
  637.         [winfo reqwidth .b3] [winfo reqheight .b3] \
  638.         [winfo reqwidth .b4] [winfo reqheight .b4]
  639. } {23 33 29 39 54 37 54 37}
  640. test button-9.3 {ComputeButtonGeometry procedure} {
  641.     eval destroy [winfo children .]
  642.     label .b1 -bitmap question -bd 3 -highlightthickness 4
  643.     button .b2 -bitmap question -bd 3 -highlightthickness 0
  644.     checkbutton .b3 -bitmap question -bd 3 -highlightthickness 1 \
  645.         -indicatoron 0
  646.     radiobutton .b4 -bitmap question -bd 3 -indicatoron false
  647.     pack .b1 .b2 .b3 .b4
  648.     update
  649.     list [winfo reqwidth .b1] [winfo reqheight .b1] \
  650.         [winfo reqwidth .b2] [winfo reqheight .b2] \
  651.         [winfo reqwidth .b3] [winfo reqheight .b3] \
  652.         [winfo reqwidth .b4] [winfo reqheight .b4]
  653. } {31 41 25 35 25 35 27 37}
  654. if $doNonPortableTests {
  655.     test button-9.4 {ComputeButtonGeometry procedure} {
  656.     eval destroy [winfo children .]
  657.     label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2\
  658.         -font -Adobe-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-*
  659.     button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2\
  660.         -font -Adobe-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-*
  661.     checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1\
  662.         -font -Adobe-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-*
  663.     radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0\
  664.         -font -Adobe-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-*
  665.     pack .b1 .b2 .b3 .b4
  666.     update
  667.     list [winfo reqwidth .b1] [winfo reqheight .b1] \
  668.         [winfo reqwidth .b2] [winfo reqheight .b2] \
  669.         [winfo reqwidth .b3] [winfo reqheight .b3] \
  670.         [winfo reqwidth .b4] [winfo reqheight .b4]
  671.     } {80 29 86 35 112 31 119 29}
  672.     test button-9.5  {ComputeButtonGeometry procedure} {
  673.     eval destroy [winfo children .]
  674.     label .l1 -text "This is a long string that will wrap around on several lines.\n\nIt also has a blank line (above)." -wraplength 1.5i -padx 0 -pady 0
  675.     pack .l1
  676.     update
  677.     list [winfo reqwidth .l1] [winfo reqheight .l1]
  678.     } {139 94}
  679.     test button-9.6  {ComputeButtonGeometry procedure} {
  680.     eval destroy [winfo children .]
  681.     label .l1 -text "This is a long string without wrapping.\n\nIt also has a blank line (above)." -padx 0 -pady 0
  682.     pack .l1
  683.     update
  684.     list [winfo reqwidth .l1] [winfo reqheight .l1]
  685.     } {216 49}
  686.     test button-9.7 {ComputeButtonGeometry procedure} {
  687.     eval destroy [winfo children .]
  688.     label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -width 10
  689.     button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -height 5
  690.     checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -width 20 -height 2
  691.     radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -width 4
  692.     pack .b1 .b2 .b3 .b4
  693.     update
  694.     list [winfo reqwidth .b1] [winfo reqheight .b1] \
  695.         [winfo reqwidth .b2] [winfo reqheight .b2] \
  696.         [winfo reqwidth .b3] [winfo reqheight .b3] \
  697.         [winfo reqwidth .b4] [winfo reqheight .b4]
  698.     } {74 23 60 89 169 40 62 23}
  699.     test button-9.8 {ComputeButtonGeometry procedure} {
  700.     eval destroy [winfo children .]
  701.     label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 \
  702.         -highlightthickness 4
  703.     button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 \
  704.         -highlightthickness 0
  705.     checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1  \
  706.         -highlightthickness 1 -indicatoron no
  707.     radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -indicatoron 0
  708.     pack .b1 .b2 .b3 .b4
  709.     update
  710.     list [winfo reqwidth .b1] [winfo reqheight .b1] \
  711.         [winfo reqwidth .b2] [winfo reqheight .b2] \
  712.         [winfo reqwidth .b3] [winfo reqheight .b3] \
  713.         [winfo reqwidth .b4] [winfo reqheight .b4]
  714.     } {62 31 56 25 58 23 62 23}
  715. }
  716.  
  717. test button-10.1 {InvokeButton procedure} {
  718.     catch {destroy .b1}
  719.     set x 0
  720.     checkbutton .b1 -variable x
  721.     set result $x
  722.     .b1 invoke
  723.     lappend result $x
  724.     .b1 invoke
  725.     lappend result $x
  726. } {0 1 0}
  727. test button-10.2 {InvokeButton procedure} {
  728.     catch {destroy .b1}
  729.     set x 0
  730.     checkbutton .b1 -variable x
  731.     trace variable x w bogusTrace
  732.     set result [list [catch {.b1 invoke} msg] $msg $x]
  733.     trace vdelete x w bogusTrace
  734.     set result
  735. } {1 {can't set "x": trace aborted} 1}
  736. test button-10.3 {InvokeButton procedure} {
  737.     catch {destroy .b1}
  738.     set x 1
  739.     checkbutton .b1 -variable x
  740.     trace variable x w bogusTrace
  741.     set result [list [catch {.b1 invoke} msg] $msg $x]
  742.     trace vdelete x w bogusTrace
  743.     set result
  744. } {1 {can't set "x": trace aborted} 0}
  745. test button-10.4 {InvokeButton procedure} {
  746.     catch {destroy .b1}
  747.     set x 0
  748.     radiobutton .b1 -variable x -value red
  749.     set result $x
  750.     .b1 invoke
  751.     lappend result $x
  752.     .b1 invoke
  753.     lappend result $x
  754. } {0 red red}
  755. test button-10.5 {InvokeButton procedure} {
  756.     catch {destroy .b1}
  757.     radiobutton .b1 -variable x -value red
  758.     set x green
  759.     trace variable x w bogusTrace
  760.     set result [list [catch {.b1 invoke} msg] $msg $errorInfo $x]
  761.     trace vdelete x w bogusTrace
  762.     set result
  763. } {1 {can't set "x": trace aborted} {can't set "x": trace aborted
  764.     while executing
  765. ".b1 invoke"} red}
  766. test button-10.6 {InvokeButton procedure} {
  767.     eval destroy [winfo children .]
  768.     set result untouched
  769.     button .b1 -command {set result invoked}
  770.     list [catch {.b1 invoke} msg] $msg $result
  771. } {0 invoked invoked}
  772. test button-10.7 {InvokeButton procedure} {
  773.     eval destroy [winfo children .]
  774.     set result untouched
  775.     set x 0
  776.     checkbutton .b1 -variable x -command {set result "invoked $x"}
  777.     list [catch {.b1 invoke} msg] $msg $result
  778. } {0 {invoked 1} {invoked 1}}
  779. test button-10.8 {InvokeButton procedure} {
  780.     eval destroy [winfo children .]
  781.     set result untouched
  782.     set x 0
  783.     radiobutton .b1 -variable x -value red -command {set result "invoked $x"}
  784.     list [catch {.b1 invoke} msg] $msg $result
  785. } {0 {invoked red} {invoked red}}
  786.  
  787. test button-11.1 {ButtonVarProc procedure} {
  788.     eval destroy [winfo children .]
  789.     set x 1
  790.     checkbutton .b1 -variable x
  791.     unset x
  792.     set result [info exists x]
  793.     .b1 toggle
  794.     lappend result $x
  795.     set x 0
  796.     .b1 toggle
  797.     lappend result $x
  798. } {0 1 1}
  799. test button-11.2 {ButtonVarProc procedure} {
  800.     eval destroy [winfo children .]
  801.     set x 0
  802.     checkbutton .b1 -variable x
  803.     set x 44
  804.     .b1 toggle
  805.     set x
  806. } {1}
  807. test button-11.3 {ButtonVarProc procedure} {
  808.     eval destroy [winfo children .]
  809.     set x 1
  810.     checkbutton .b1 -variable x
  811.     set x 44
  812.     .b1 toggle
  813.     set x
  814. } {1}
  815. test button-11.4 {ButtonVarProc procedure} {
  816.     eval destroy [winfo children .]
  817.     set x 0
  818.     checkbutton .b1 -variable x
  819.     set x 1
  820.     .b1 toggle
  821.     set x
  822. } {0}
  823. test button-11.5 {ButtonVarProc procedure} {
  824.     eval destroy [winfo children .]
  825.     set x 1
  826.     checkbutton .b1 -variable x
  827.     set x 1
  828.     .b1 toggle
  829.     set x
  830. } {0}
  831. test button-11.6 {ButtonVarProc procedure} {
  832.     eval destroy [winfo children .]
  833.     set x 0
  834.     checkbutton .b1 -variable x
  835.     set x 0
  836.     .b1 toggle
  837.     set x
  838. } {1}
  839. test button-11.7 {ButtonVarProc procedure} {
  840.     eval destroy [winfo children .]
  841.     set x 1
  842.     checkbutton .b1 -variable x
  843.     set x 0
  844.     .b1 toggle
  845.     set x
  846. } {1}
  847.  
  848. test button-12.1 {ButtonTextVarProc procedure} {
  849.     eval destroy [winfo children .]
  850.     set x Label
  851.     button .b1 -textvariable x
  852.     unset x
  853.     set result [list $x [lindex [.b1 configure -text] 4]]
  854.     set x New
  855.     lappend result [lindex [.b1 configure -text] 4]
  856. } {Label Label New}
  857. test button-12.2 {ButtonTextVarProc procedure} {
  858.     eval destroy [winfo children .]
  859.     set x Label
  860.     button .b1 -textvariable x
  861.     set old [winfo reqwidth .b1]
  862.     set x New
  863.     set new [winfo reqwidth .b1]
  864.     list [lindex [.b1 configure -text] 4] [expr $old == $new]
  865. } {New 0}
  866.  
  867. test button-13.1 {ButtonImageProc procedure} {
  868.     eval destroy [winfo children .]
  869.     eval image delete [image names]
  870.     image create test image1
  871.     label .b1 -image image1 -padx 0 -pady 0 -bd 0
  872.     pack .b1
  873.     set result "[winfo reqwidth .b1] [winfo reqheight .b1]"
  874.     image1 changed 0 0 0 0 80 100
  875.     lappend result [winfo reqwidth .b1] [winfo reqheight .b1]
  876. } {30 15 80 100}
  877.  
  878. eval destroy [winfo children .]
  879.