1# 2# Tests for [incr Tk] widgets based on itk::Widget 3# ---------------------------------------------------------------------- 4# AUTHOR: Michael J. McLennan 5# Bell Labs Innovations for Lucent Technologies 6# mmclennan@lucent.com 7# http://www.tcltk.com/itcl 8# 9# RCS: $Id: widget.test,v 1.6 2004/09/22 09:37:09 davygrvy Exp $ 10# ---------------------------------------------------------------------- 11# Copyright (c) 1993-1998 Lucent Technologies, Inc. 12# ====================================================================== 13# See the file "license.terms" for information on usage and 14# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 15 16package require tcltest 17namespace import -force ::tcltest::* 18 19::tcltest::loadTestedCommands 20 21 22# ---------------------------------------------------------------------- 23# Simple mega-widget 24# ---------------------------------------------------------------------- 25test widget-1.1 {define a simple mega-widget class} { 26 option add *TestWidget.background linen 27 option add *TestWidget.borderWidth 2 28 option add *TestWidget.command "" 29 option add *TestWidget.cursor "" 30 option add *TestWidget.foreground navy 31 option add *TestWidget.highlight white 32 option add *TestWidget.normal ivory 33 option add *TestWidget.text "" 34 35 itcl::class TestWidget { 36 inherit itk::Widget 37 constructor {args} { 38 itk_component add test1 { 39 label $itk_interior.t1 40 } { 41 keep -background -foreground -cursor 42 keep -text 43 } 44 pack $itk_component(test1) -side left -padx 2 45 46 itk_component add test2 { 47 button $itk_interior.t2 -text "Push Me" 48 } { 49 keep -foreground -cursor -borderwidth -command 50 rename -background -normal normal Background 51 rename -activebackground -highlight highlight Foreground 52 } 53 pack $itk_component(test2) -side right -fill x -pady 2 54 55 eval itk_initialize $args 56 } 57 private variable status "" 58 public method action {info} { 59 lappend status $info 60 } 61 62 public method do {cmd} { 63 eval $cmd 64 } 65 66 itk_option define -status status Status {} { 67 lappend status $itk_option(-status) 68 } 69 } 70 TestWidget .#auto 71} {.testWidget0} 72 73pack .testWidget0 74 75test widget-1.2 {check the list of configuration options} { 76 .testWidget0 configure 77} {{-background background Background linen linen} {-borderwidth borderWidth BorderWidth 2 2} {-clientdata clientData ClientData {} {}} {-command command Command {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-highlight highlight Foreground white white} {-normal normal Background ivory ivory} {-status status Status {} {}} {-text text Text {} {}}} 78 79set unique 0 80foreach test { 81 {-background {-background background Background linen linen}} 82 {-borderwidth {-borderwidth borderWidth BorderWidth 2 2}} 83 {-clientdata {-clientdata clientData ClientData {} {}}} 84 {-command {-command command Command {} {}}} 85 {-cursor {-cursor cursor Cursor {} {}}} 86 {-foreground {-foreground foreground Foreground navy navy}} 87 {-highlight {-highlight highlight Foreground white white}} 88 {-normal {-normal normal Background ivory ivory}} 89 {-status {-status status Status {} {}}} 90 {-text {-text text Text {} {}}} 91} { 92 set opt [lindex $test 0] 93 set result [lindex $test 1] 94 95 test widget-1.3.[incr unique] {check individual configuration options} { 96 .testWidget0 configure $opt 97 } $result 98} 99 100set unique 0 101foreach test { 102 {-background red} 103 {-borderwidth 1} 104 {-clientdata "foo bar"} 105 {-command {puts "hello!"}} 106 {-cursor trek} 107 {-foreground IndianRed} 108 {-highlight MistyRose} 109 {-normal MistyRose2} 110 {-status "test message"} 111 {-text "Label:"} 112} { 113 set opt [lindex $test 0] 114 set value [lindex $test 1] 115 116 test widget-1.4.[incr unique] {set individual configuration options} { 117 list [.testWidget0 configure $opt $value] \ 118 [.testWidget0 cget $opt] \ 119 [.testWidget0 do "set itk_option($opt)"] 120 } [list "" $value $value] 121} 122 123test widget-1.5 {check the list components} { 124 lsort [.testWidget0 component] 125} {hull test1 test2} 126 127set unique 0 128foreach test { 129 {hull .testWidget0} 130 {test1 .testWidget0.t1} 131 {test2 .testWidget0.t2} 132} { 133 set name [lindex $test 0] 134 set win [lindex $test 1] 135 136 test widget-1.6 {check the window for each component} { 137 list [.testWidget0 component $name] \ 138 [.testWidget0 do "set itk_component($name)"] 139 } [list $win $win] 140} 141 142test widget-1.7 {check the propagation of configuration options} { 143 list [.testWidget0 component hull cget -cursor] \ 144 [.testWidget0 component test1 cget -cursor] \ 145 [.testWidget0 component test2 cget -cursor] 146} {trek trek trek} 147 148test widget-1.8 {check the propagation of configuration options} { 149 list [.testWidget0 component hull cget -background] \ 150 [.testWidget0 component test1 cget -background] \ 151 [.testWidget0 component test2 cget -background] 152} {red red MistyRose2} 153 154test widget-1.9 {check the propagation of configuration options} { 155 list [.testWidget0 component test1 cget -text] \ 156 [.testWidget0 component test2 cget -text] 157} {Label: {Push Me}} 158 159test widget-1.10 {check the invocation of "config" code} { 160 .testWidget0 do {set status} 161} {{} {test message}} 162 163test widget-1.11a {configure using the "code" command} { 164 .testWidget0 do {configure -command [itcl::code $this action "button press"]} 165 .testWidget0 cget -command 166} {namespace inscope ::TestWidget {::.testWidget0 action {button press}}} 167 168test widget-1.11b {execute some code created by "code" command} { 169 .testWidget0 do {set status ""} 170 .testWidget0 component test2 invoke 171 .testWidget0 configure -status "in between" 172 .testWidget0 component test2 invoke 173 .testWidget0 do {set status} 174} {{button press} {in between} {button press}} 175 176test widget-1.12a {components can be added on the fly} { 177 .testWidget0 do { 178 itk_component add test3 { 179 label $itk_interior.t3 -text "Temporary" 180 } { 181 keep -background -foreground -cursor 182 } 183 } 184} {test3} 185 186test widget-1.12b {components can be added on the fly} { 187 .testWidget0 do { 188 pack $itk_component(test3) -fill x 189 } 190} {} 191 192test widget-1.13 {new components show up on the component list} { 193 lsort [.testWidget0 component] 194} {hull test1 test2 test3} 195 196test widget-1.14 {new components are initialized properly} { 197 list [.testWidget0 component test3 cget -background] \ 198 [.testWidget0 component test3 cget -foreground] \ 199 [.testWidget0 component test3 cget -cursor] 200} {red IndianRed trek} 201 202test widget-1.15 {components can be deleted like ordinary widgets} { 203 destroy [.testWidget0 component test3] 204} {} 205 206test widget-1.16 {dead components are removed from the component list} { 207 lsort [.testWidget0 component] 208} {hull test1 test2} 209 210test widget-1.17 {use "configbody" command to change "config" code} { 211 itcl::configbody TestWidget::status {lappend status "new"} 212} {} 213 214test widget-1.18 {"config" code can really change} { 215 .testWidget0 do {set status ""} 216 .testWidget0 configure -status "test message" 217 .testWidget0 configure -status "another" 218 .testWidget0 do {set status} 219} {new new} 220 221test widget-1.19 {"config" code can change back} { 222 itcl::configbody TestWidget::status {lappend status $itk_option(-status)} 223} {} 224 225test widget-1.20 {mega-widgets show up on the object list} { 226 itcl::find objects .testWidget* 227} {.testWidget0} 228 229test widget-1.21 {when a mega-widget is destroyed, its object is deleted} { 230 destroy .testWidget0 231 itcl::find objects .testWidget* 232} {} 233 234test widget-1.22 {recreate a test widget} { 235 TestWidget .testWidget0 236 itcl::find objects .testWidget* 237} {.testWidget0} 238 239test widget-1.23 {when an object is deleted the widget is destroyed} { 240 itcl::delete object .testWidget0 241 winfo exists .testWidget0 242} {0} 243 244test widget-1.24 {recreate another test widget} { 245 TestWidget .testWidget 246} {.testWidget} 247 248test widget-1.25 {when an internal component is destroyed, it is removed from the list of components, and any dead options disappear} { 249 list [lsort [.testWidget component]] \ 250 [.testWidget configure] \ 251 [catch {destroy [.testWidget component test1]}] \ 252 [.testWidget component] \ 253 [.testWidget do {return [lsort [array names itk_component]]}] \ 254 [.testWidget configure] 255} {{hull test1 test2} {{-background background Background linen linen} {-borderwidth borderWidth BorderWidth 2 2} {-clientdata clientData ClientData {} {}} {-command command Command {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-highlight highlight Foreground white white} {-normal normal Background ivory ivory} {-status status Status {} {}} {-text text Text {} {}}} 0 {hull test2} {hull test2} {{-background background Background linen linen} {-borderwidth borderWidth BorderWidth 2 2} {-clientdata clientData ClientData {} {}} {-command command Command {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-highlight highlight Foreground white white} {-normal normal Background ivory ivory} {-status status Status {} {}}}} 256 257test widget-1.26 {when an internal component is deleted (but not destroyed) it is disconnected from the option list and its binding tags are updated} { 258 set comp [.testWidget component test2] 259 list [bindtags $comp] \ 260 [bind itk-destroy-$comp <Destroy>] \ 261 [catch {.testWidget do {itk_component delete test2}}] \ 262 [bindtags $comp] \ 263 [bind itk-destroy-$comp <Destroy>] \ 264 [.testWidget configure] 265} {{itk-destroy-.testWidget.t2 .testWidget.t2 Button . all} {namespace inscope ::itk::Archetype {::.testWidget itk_component delete test2}} 0 {.testWidget.t2 Button . all} {} {{-background background Background linen linen} {-clientdata clientData ClientData {} {}} {-cursor cursor Cursor {} {}} {-status status Status {} {}}}} 266 267test widget-1.27 {when a mega-widget object is deleted, its window and any 268 components are destroyed (even if in another window) } { 269 catch {destroy .t1} 270 catch {rename .t1.bw {}} 271 catch {itcl::delete class ButtonWidget} 272 273 itcl::class ButtonWidget { 274 inherit itk::Widget 275 276 constructor {args} { 277 eval itk_initialize $args 278 279 itk_component add button { 280 button $itk_option(-container).b -text Button 281 } {} 282 pack $itk_component(button) 283 } 284 285 itk_option define -container container Container {} 286 } 287 288 toplevel .t1 289 frame .t1.f 290 ButtonWidget .t1.bw -container .t1.f 291 292 pack .t1.f 293 pack .t1.bw 294 295 set button [.t1.bw component button] 296 itcl::delete object .t1.bw 297 set result [list $button [winfo exists $button]] 298 destroy .t1 299 itcl::delete class ButtonWidget 300 set result 301} {.t1.f.b 0} 302 303test widget-1.28 {when a window that contains a megawidget component 304 is destroyed, the component is removed from the megawidget} { 305 catch {destroy .t1} 306 catch {rename .t1.bw {}} 307 catch {itcl::delete class ButtonWidget} 308 309 itcl::class ButtonWidget { 310 inherit itk::Widget 311 312 constructor {args} { 313 eval itk_initialize $args 314 315 itk_component add button { 316 button $itk_option(-container).b -text Button 317 } {} 318 pack $itk_component(button) 319 } 320 321 itk_option define -container container Container {} 322 } 323 324 toplevel .t1 325 frame .t1.f 326 ButtonWidget .t1.bw -container .t1.f 327 328 pack .t1.f 329 pack .t1.bw 330 set result [list [.t1.bw component]] 331 destroy .t1.f 332 lappend result [list [.t1.bw component]] 333 334 itcl::delete object .t1.bw 335 destroy .t1 336 itcl::delete class ButtonWidget 337 set result 338} {{button hull} hull} 339 340test widget-1.29 {when destroying a component that is inside another 341 window protect against that case where one component destroy 342 actually destroys other contained components} { 343 catch {destroy .t1} 344 catch {rename .t1.bw {}} 345 catch {itcl::delete class ButtonWidget} 346 347 itcl::class ButtonWidget { 348 inherit itk::Widget 349 350 constructor {args} { 351 eval itk_initialize $args 352 353 # Note, the component names matter here since 354 # [.t2 component] returns names in hash order. 355 # We need to delete cframe first since it 356 # is the parent of cbutton. 357 358 itk_component add cframe { 359 button $itk_option(-container).cframe 360 } {} 361 pack $itk_component(cframe) 362 363 itk_component add cbutton { 364 button $itk_component(cframe).b -text Button 365 } {} 366 pack $itk_component(cbutton) 367 } 368 369 itk_option define -container container Container {} 370 } 371 372 toplevel .t1 373 frame .t1.f 374 ButtonWidget .t1.bw -container .t1.f 375 376 pack .t1.f 377 pack .t1.bw 378 set result [list [.t1.bw component]] 379 # destructor should destroy cframe but not cbutton 380 itcl::delete object .t1.bw 381 lappend result [winfo exists .t1.f.cframe] 382 383 destroy .t1 384 itcl::delete class ButtonWidget 385 set result 386} {{hull cframe cbutton} 0} 387 388 389# ---------------------------------------------------------------------- 390# Clean up 391# ---------------------------------------------------------------------- 392itcl::delete class TestWidget 393 394::tcltest::cleanupTests 395exit 396