1# This file is a Tcl script to test out [incr Widgets] Menubar class. 2# It is organized in the standard fashion for Tcl tests with the following 3# notation for test case labels: 4# 5# 1.x - Construction/Destruction tests 6# 2.x - Configuration option tests 7# 3.x - Method tests 8# 9# Copyright (c) 1995 DSC Technologies Corporation 10# 11# See the file "license.terms" for information on usage and redistribution 12# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13# 14# @(#) $Id: menubar.test,v 1.4 2001/08/07 19:56:48 smithc Exp $ 15 16package require tcltest 17namespace import -force ::tcltest::* 18 19if [catch {package require Iwidgets 4.0}] { 20 # Let's try modifying the auto_path. Note that the IWIDGETS_LIBRARY 21 # env var is initialized in the Makefile when doing a 'make test'. 22 # If sourcing this file independently, this variable must be set manually. 23 if ![info exists env(IWIDGETS_LIBRARY)] { 24 error "Unable to locate Iwidgets package. Set your IWIDGETS_LIBRARY\ 25 environment\nvariable to the directory that contains iwidgets.tcl" 26 } 27 lappend auto_path $env(IWIDGETS_LIBRARY) 28 package require Iwidgets 4.0 29} 30 31if {[string compare test [info procs test]] == 1} { 32 source defs 33} 34 35wm geometry . {} 36raise . 37 38set c 1 39set o 1 40set m 1 41 42# 43# Initial construction test 44# 45test Menubar-1.$c {Menubar construction} { 46 iwidgets::Menubar .mb -menubuttons { 47 menubutton file -text File -menu { 48 options -tearoff no 49 command ok -label "Ok" 50 command quit -label "Quit" 51 } 52 } 53 pack .mb 54 update 55 .mb add menubutton .other -text Other -menu { 56 radiobutton r1 -label "Radio One" 57 radiobutton r2 -label "Radio Two" 58 } 59 update 60 .mb add menubutton view -text View -menu { 61 command uno -label Uno 62 command dos -label Dos 63 } 64 update 65 .mb add cascade .view.more -label More -menu { 66 command one -label One 67 command two -label Two 68 cascade extra -label Extra -menu { 69 radiobutton rad1 -label "Choice One" 70 radiobutton rad2 -label "Choice Two" 71 cascade somemore \ 72 -label "Some More" \ 73 -helpstr "Yet some more" \ 74 -menu { 75 command triangle -label "Triangle" -command {puts TRIANGLE} 76 command square -label "Square" -command {puts SQUARE} 77 command octagon -label "Octagon" -command {puts OCTAGON} 78 } 79 } 80 } 81 update 82} {} 83 84incr c 85 86# 87# Option tests which are successful. 88# 89test Menubar-2.$o {configuration option} { 90 llength [.mb configure] 91} {22} 92 93incr o 94 95foreach test { 96 {-anchor center center } 97 {-disabledforeground #a3a3a3 #a3a3a3 } 98 {-menubuttons {} {} } 99 {-highlightthickness 0 0 } 100 {-borderwidth 2 2 } 101 {-helpvariable {} {} } 102 {-highlightcolor Black Black } 103 {-font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* } 104 {-background #CDCDB7B7B5B5 #CDCDB7B7B5B5 } 105 {-highlightbackground #d9d9d9 #d9d9d9 } 106 {-activeborderwidth 2 2 } 107 {-wraplength 0 0 } 108 {-activebackground #ececec #ececec } 109 {-padx 4 4 } 110 {-pady 4 4 } 111 {-justify center center } 112 {-cursor {} {} } 113 {-activeforeground black black } 114 {-width 0 0 } 115 {-height 0 0 } 116 } { 117 set option [lindex $test 0] 118 test Menubar-2.$o "configuration options, $option" { 119 .mb configure $option [lindex $test 1] 120 .mb cget $option 121 } [lindex $test 2] 122 update 123 incr o 124} 125 126# 127# Menuconfigure Option tests which are successful. 128# 129# This happens to be for a command... 130test Menubar-3.$o {menubar menuconfiguration option} { 131 llength [.mb menuconfigure .file.quit] 132} {15} 133 134# do menuconfigure tests also... 135foreach test { 136 { .file.quit -activebackground red red } 137 { .file.quit -activeforeground red red } 138 { .file.quit -accelerator {} {} } 139 { .file.quit -background red red } 140 { .file.quit -bitmap {} {} } 141 { .file.quit -command {} {} } 142 { .file.quit -font fixed fixed } 143 { .file.quit -foreground red red } 144 { .file.quit -image {} {} } 145 { .file.quit -label hello hello } 146 { .file.quit -state normal normal } 147 { .file.quit -underline -1 -1 } 148 { .file.quit -helpstr {} {} } 149 } { 150 set index [lindex $test 0] 151 set option [lindex $test 1] 152 test Menubar-2.$o "tab configuration options, $option" { 153 .mb menuconfigure $index $option [lindex $test 2] 154 .mb menucget $index $option 155 } [lindex $test 3] 156 update 157 incr o 158} 159 160# test on cascade item 161# This happens to be for a cascade... 162test Menubar-3.$o {menubar menuconfiguration option} { 163 llength [.mb menuconfigure .view.more] 164} {17} 165 166# do menuconfigure tests also... 167foreach test { 168 { .view.more -activebackground red red } 169 { .view.more -activeforeground red red } 170 { .view.more -accelerator {} {} } 171 { .view.more -background red red} 172 { .view.more -bitmap {} {} } 173 { .view.more -command {} {} } 174 { .view.more -font } 175 { .view.more -foreground } 176 { .view.more -image {} {} } 177 { .view.more -label {} {} } 178 { .view.more -state normal normal } 179 { .view.more -underline -1 -1 } 180 { .view.more -helpstr {} {} } 181 } { 182 set index [lindex $test 0] 183 set option [lindex $test 1] 184 test Menubar-2.$o "tab configuration options, $option" { 185 .mb menuconfigure $index $option [lindex $test 2] 186 .mb menucget $index $option 187 } [lindex $test 3] 188 update 189 incr o 190} 191 192# 193# Option tests which fail and produce errors. 194# 195#foreach test { 196# { -OPTION BADVALUE {ERROR_MESSAGE} } 197# } { 198# set option [lindex $test 0] 199# test Menubar-2.$o "configuration options, $option" { 200# list [catch {.bb configure $option [lindex $test 1]} msg] $msg 201# } [list 1 [lindex $test 2]] 202# incr o 203#} 204 205# 206# Method tests which are successful. 207# 208foreach test { 209 {{.mb delete 0 end} 210 {}} 211 {{.mb add menubutton .help -text Help} 212 {}} 213 {{.mb add command .help.context -label "On Context..."} 214 {}} 215 {{.mb insert .help.context command index -label "By Index..."} 216 {}} 217 {{.mb delete .help} 218 {}} 219 {{.mb add menubutton .help -text HELP -menu { 220 command index -label "By Index..." 221 command context -label "By Context..." 222 separator sep1 223 command keyword -label "By Keyword..." 224 }} 225 {}} 226 {{.mb delete .help.sep1 .help.keyword} 227 {}} 228 {{.mb menuconfigure .help -text HeLp -menu { 229 command index -label "By Index..." 230 command context -label "By Context..." 231 separator sep1 232 command keyword -label "By Keyword..." 233 }} 234 {}} 235 {{.mb configure -menubuttons { 236 menubutton file -text File -menu { 237 options -tearoff on 238 command ok -label "OK" 239 command quit -label "Quit" 240 } 241 }} 242 {}} 243 {{.mb add menubutton .other -text Other -menu { 244 radiobutton r1 -label "Radio One" 245 radiobutton r2 -label "Radio Two" 246 }} 247 {}} 248 {{.mb insert .other menubutton view -text View -menu { 249 command uno -label Uno 250 command dos -label Dos 251 }} 252 {}} 253 {{.mb add cascade .view.more -label More -menu { 254 command one -label One 255 command two -label Two 256 cascade extra -label Extra -menu { 257 radiobutton rad1 -label "Choice One" 258 radiobutton rad2 -label "Choice Two" 259 cascade somemore \ 260 -label "Some More" \ 261 -helpstr "Yet some more" \ 262 -menu { 263 command triangle -label "Triangle" -command {puts TRIANGLE} 264 command square -label "Square" -command {puts SQUARE} 265 command octagon -label "Octagon" -command {puts OCTAGON} 266 } 267 } 268 }} 269 {}} 270 {{.mb insert .view.uno cascade before -label Before -menu { 271 command red -label Red 272 command green -label Green 273 command blue -label Blue 274 }} 275 {}} 276 {{.mb add menubutton .help -text Help} 277 {}} 278 {{.mb add command .help.context -label "On Context..."} 279 {}} 280 {{.mb insert .help.context command index -label "By Index..."} 281 {}} 282 {{.mb insert .view.before.green cascade colors -label Colors -menu { 283 command orange -label Orange -command "puts ORANGE" -helpstr "orange" 284 separator sep1 285 command purple -label Purple 286 }} 287 288 {}} 289 {{.mb insert .view.before.colors.purple cascade morecolors -label "More Colors" -menu {}} 290 {}} 291 {{.mb add command .view.before.colors.morecolors.pink -label Pink} 292 {}} 293 {{.mb add command .view.before.colors.morecolors.peach -label Peach} 294 {}} 295 {{.mb add command .view.before.colors.morecolors.yellow -label Yellow} 296 {}} 297 {{.mb menuconfigure .view -text VIEW -menu { 298 command o -label OH -command {puts OH} 299 cascade negative -label Negative -menu { 300 command print -label Print 301 command save -label Save 302 } 303 # Comments are supported. 304# command dummy -label PlaceHolder 305 cascade plus -label Plus -menu { 306 command yep -label Yep 307 command nope -label Nope 308 } 309 }} 310 {}} 311 {{.mb menuconfigure .view.negative -label NEGATIVE -menu { 312 command print -label PRINT 313 command save -label SAVE 314 }} 315 {}} 316 {{.mb delete .0 .end} 317 {}} 318 } { 319 set method [lindex [lindex $test 0] 1] 320 set method_invoke [lindex $test 0] 321 322 set testContents "set msg {}\n" 323 append testContents \ 324 "set result \[catch \{[lindex $test 0]\} msg\]\n" 325 append testContents \ 326 "lappend result \[regexp -- \{[lindex $test 1]\} \$msg\] \n" 327 append testContents "set result\n" 328 test Menubar-4.$m "\[$method_invoke\]" $testContents \ 329 [list 0 1] 330 update 331 incr m 332} 333 334# 335# Method tests which fail and produce errors or results 336# Specifically, deals with method invocation on empty menubar. 337# 338foreach test { 339 {1 {.mb delete .0 .last} 340 {bad path:}} 341 {0 {.mb index .0} 342 {-1}} 343 {0 {.mb index .end} 344 {-1}} 345 {0 {.mb index .last} 346 {-1}} 347 {0 {.mb index .help} 348 {-1}} 349 {1 {.mb delete .0} 350 {bad path:}} 351 {1 {.mb delete .end} 352 {bad path:}} 353 {1 {.mb delete .last} 354 {bad path:}} 355 {1 {.mb delete .help} 356 {bad path:}} 357 {1 {.mb insert .0 menubutton file -text File} 358 {bad path:}} 359 {1 {.mb insert .end menubutton file -text File} 360 {bad path:}} 361 {1 {.mb insert .last menubutton file -text File} 362 {bad path:}} 363 {1 {.mb insert .help menubutton file -text File} 364 {bad path:}} 365 {1 {.mb invoke .0.0} 366 {bad path:}} 367 {1 {.mb invoke .end.0} 368 {bad path:}} 369 {1 {.mb invoke .last.0} 370 {bad path:}} 371 {1 {.mb invoke .help.0} 372 {bad path:}} 373 {1 {.mb menucget .0 -text} 374 {bad path:}} 375 {1 {.mb menucget .end -text} 376 {bad path:}} 377 {1 {.mb menucget .last -text} 378 {bad path:}} 379 {1 {.mb menucget .help -text} 380 {bad path:}} 381 {1 {.mb menuconfigure .0 -text} 382 {bad path:}} 383 {1 {.mb menuconfigure .end -text} 384 {bad path:}} 385 {1 {.mb menuconfigure .last -text} 386 {bad path:}} 387 {1 {.mb menuconfigure .help -text} 388 {bad path:}} 389 {0 {.mb path *quit} 390 {}} 391 {1 {.mb type .0.0} 392 {bad path:}} 393 {1 {.mb type .0.end} 394 {bad path:}} 395 {1 {.mb type .0.last} 396 {bad path:}} 397 {1 {.mb type .0.new} 398 {bad path:}} 399 {1 {.mb yposition .0.new} 400 {bad path:}} 401 } { 402 set method_status [lindex $test 0] 403 set method_invoke [lindex $test 1] 404 set method [lindex $method_invoke 1] 405 406 set testContents "set msg {}\n" 407 append testContents \ 408 "set result \[catch \{$method_invoke\} msg\]\n" 409 append testContents \ 410 "lappend result \[regexp -- \{[lindex $test 2]\} \$msg\] \n" 411 append testContents "set result\n" 412 test Menubar-5.$m "\[$method_invoke\]" $testContents \ 413 [list $method_status 1] 414 incr m 415 } 416 417# 418# Method tests which fail and produce errors or results 419# On a non-empty menubar... 420foreach test { 421 {0 {.mb configure -menubuttons { 422 menubutton file -text File -menu { 423 options -tearoff no 424 command ok -label "Ok" 425 command quit -label "Quit" 426 } 427 }} 428 {}} 429 {1 {.mb delete .file.hello} 430 {bad path}} 431 {0 {.mb index .0.hello} 432 {-1}} 433 {0 {.mb index .0.quit} 434 {1}} 435 {0 {.mb index 0.end} 436 {1}} 437 {0 {.mb index .file.last} 438 {1}} 439 {0 {.mb index .file.ok} 440 {0}} 441 {1 {.mb delete .view .file} 442 {bad path:}} 443 {1 {.mb delete .file .help} 444 {bad path:}} 445 {1 {.mb add command .file.menu} 446 {bad name}} 447 {1 {.mb add command .file.last} 448 {bad name}} 449 {1 {.mb add command .file.end} 450 {bad name}} 451 {1 {.mb add command .file.2} 452 {bad name}} 453 {1 {.mb insert .0 menu view -text View} 454 {bad type}} 455 {1 {.mb insert .file command view -text View} 456 {bad entry path}} 457 {0 {.mb insert .file menubutton view -text View} 458 {[.]mb[.]menubar[.]view}} 459 {1 {.mb invoke .0.quit} 460 {bad path}} 461 {0 {.mb menucget .0 -text} 462 {View}} 463 {0 {.mb menucget .end -text} 464 {File}} 465 {0 {.mb menucget .last -text} 466 {File}} 467 {1 {.mb menucget .help -text} 468 {bad path}} 469 {0 {.mb menuconfigure .0 -text} 470 {-text text Text {} View}} 471 {0 {.mb menuconfigure .end.last -label} 472 {-label {} {} {} Quit}} 473 {0 {.mb menuconfigure .last -text} 474 {-text text Text {} File}} 475 {1 {.mb menuconfigure .help -text} 476 {bad path}} 477 {0 {.mb path *quit} 478 {[.]file[.]quit}} 479 {0 {.mb type .end.0} 480 {command}} 481 {0 {.mb type .end.end} 482 {command}} 483 {0 {.mb type .end.last} 484 {command}} 485 {1 {.mb type .0.new} 486 {bad path}} 487 } { 488 set method_status [lindex $test 0] 489 set method_invoke [lindex $test 1] 490 set method [lindex $method_invoke 1] 491 492 set testContents "set msg {}\n" 493 append testContents \ 494 "set result \[catch \{$method_invoke\} msg\]\n" 495 append testContents \ 496 "lappend result \[regexp -- \{[lindex $test 2]\} \$msg\] \n" 497 append testContents "set result\n" 498 test Menubar-5.$m "\[$method_invoke\]" $testContents \ 499 [list $method_status 1] 500 incr m 501 } 502 503# 504# Conclusion of constrcution/destruction tests 505# 506test Menubar-1.$c {Menubar destruction} { 507 destroy .mb 508 update 509} {} 510 511incr c 512 513test Menubar-1.$c {Menubar construction} { 514 iwidgets::Menubar .mb -menubuttons { 515 menubutton file -text File -menu { 516 options -tearoff no 517 command ok -label "Ok" 518 command quit -label "Quit" 519 } 520 } 521 pack .mb 522 update 523 .mb add menubutton .other -text Other -menu { 524 radiobutton r1 -label "Radio One" 525 radiobutton r2 -label "Radio Two" 526 } 527 update 528 .mb add menubutton view -text View -menu { 529 command uno -label Uno 530 command dos -label Dos 531 } 532 update 533 .mb add cascade .view.more -label More -menu { 534 command one -label One 535 command two -label Two 536 cascade extra -label Extra -menu { 537 radiobutton rad1 -label "Choice One" 538 radiobutton rad2 -label "Choice Two" 539 cascade somemore \ 540 -label "Some More" \ 541 -helpstr "Yet some more" \ 542 -menu { 543 command triangle -label "Triangle" -command {puts TRIANGLE} 544 command square -label "Square" -command {puts SQUARE} 545 command octagon -label "Octagon" -command {puts OCTAGON} 546 } 547 } 548 } 549 update 550} {} 551 552incr c 553 554test Menubar-1.$c {Menubar destruction} { 555 destroy .mb 556 update 557} {} 558 559::tcltest::cleanupTests 560exit 561