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