diff options
Diffstat (limited to 'tests/frame.test')
| -rw-r--r-- | tests/frame.test | 369 |
1 files changed, 192 insertions, 177 deletions
diff --git a/tests/frame.test b/tests/frame.test index 07258da..affdac6 100644 --- a/tests/frame.test +++ b/tests/frame.test @@ -8,10 +8,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands # eatColors -- @@ -121,23 +118,22 @@ foreach test { {-takefocus "any string" "any string" {} {}} {-width 32 32 badValue {bad screen distance "badValue"}} } { - set name [lindex $test 0] + lassign $test opt goodValue goodResult badValue badResult test frame-1.$i {frame configuration options} { - .f configure $name [lindex $test 1] - lindex [.f configure $name] 4 - } [lindex $test 2] + .f configure $opt $goodValue + lindex [.f configure $opt] 4 + } $goodResult incr i - if {[lindex $test 3] != ""} { - test frame-1.$i {frame configuration options} { - list [catch {.f configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] + if {$badValue ne ""} { + test frame-1.$i {frame configuration options} -body { + .f configure $opt $badValue + } -returnCodes error -result $badResult } - .f configure $name [lindex [.f configure $name] 3] + .f configure $opt [lindex [.f configure $opt] 3] incr i } destroy .f -set i 1 test frame-2.1 {toplevel configuration options} { catch {destroy .t} toplevel .t -width 200 -height 100 -class NewClass @@ -152,7 +148,7 @@ test frame-2.2 {toplevel configuration options} { } {{-colormap colormap Colormap {} new} 1 {can't modify -colormap option after widget is created}} test frame-2.3 {toplevel configuration options} { catch {destroy .t} - toplevel .t -width 200 -height 100 -colormap {} -use {} + toplevel .t -width 200 -height 100 wm geometry .t +0+0 list [catch {.t configure -container 1} msg] $msg [.t configure -container] } {1 {can't modify -container option after widget is created} {-container container Container 0 0}} @@ -161,12 +157,22 @@ test frame-2.4 {toplevel configuration options} { list [catch {toplevel .t -width 200 -height 100 -colormap bogus} msg] $msg } {1 {bad window path name "bogus"}} set default "[winfo visual .] [winfo depth .]" +if {$tcl_platform(platform) == "windows"} { +test frame-2.5 {toplevel configuration options} { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +0+0 + list [catch {.t configure -use 0x44022} msg] $msg [.t configure -use] +} {1 {window "0x44022" doesn't exist} {-use use Use {} {}}} +} else { test frame-2.5 {toplevel configuration options} { catch {destroy .t} toplevel .t -width 200 -height 100 wm geometry .t +0+0 list [catch {.t configure -use 0x44022} msg] $msg [.t configure -use] } {1 {can't modify -use option after widget is created} {-use use Use {} {}}} +} + test frame-2.6 {toplevel configuration options} { catch {destroy .t} toplevel .t -width 200 -height 100 -visual default @@ -177,15 +183,14 @@ test frame-2.7 {toplevel configuration options} { catch {destroy .t} list [catch {toplevel .t -width 200 -height 100 -visual who_knows?} msg] $msg } {1 {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}} -if [info exists env(DISPLAY)] { - test frame-2.8 {toplevel configuration options} { - catch {destroy .t} - toplevel .t -width 200 -height 100 -screen $env(DISPLAY) - wm geometry .t +0+0 - list [.t configure -screen] \ - [catch {.t configure -screen another} msg] $msg - } [list [list -screen screen Screen {} $env(DISPLAY)] 1 {can't modify -screen option after widget is created}] -} +test frame-2.8 {toplevel configuration options} haveDISPLAY { + catch {destroy .t} + toplevel .t -width 200 -height 100 -screen $env(DISPLAY) + wm geometry .t +0+0 + set cfg [string compare [.t configure -screen] \ + "-screen screen Screen {} $env(DISPLAY)"] + list $cfg [catch {.t configure -screen another} msg] $msg +} {0 1 {can't modify -screen option after widget is created}} test frame-2.9 {toplevel configuration options} { catch {destroy .t} list [catch {toplevel .t -width 200 -height 100 -screen bogus} msg] $msg @@ -235,39 +240,41 @@ foreach test { {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} {-width 32 32 badValue {bad screen distance "badValue"}} } { - set name [lindex $test 0] + lassign $test opt goodValue goodResult badValue badResult test frame-2.$i {toplevel configuration options} { - .t configure $name [lindex $test 1] - lindex [.t configure $name] 4 - } [lindex $test 2] + .t configure $opt $goodValue + lindex [.t configure $opt] 4 + } $goodResult incr i - if {[lindex $test 3] != ""} { - test frame-2.$i {toplevel configuration options} { - list [catch {.t configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] + if {$badValue ne ""} { + test frame-2.$i {toplevel configuration options} -body { + .t configure $opt $badValue + } -returnCodes error -result $badResult } - .t configure $name [lindex [.t configure $name] 3] + .t configure $opt [lindex [.t configure $opt] 3] incr i } -test frame-3.1 {TkCreateFrame procedure} { - list [catch frame msg] $msg -} {1 {wrong # args: should be "frame pathName ?options?"}} -test frame-3.2 {TkCreateFrame procedure} { +test frame-3.1 {TkCreateFrame procedure} -body { + frame +} -returnCodes error -result {wrong # args: should be "frame pathName ?options?"} +test frame-3.2 {TkCreateFrame procedure} -setup { catch {destroy .f} frame .f - set result [.f configure -class] +} -body { + .f configure -class +} -cleanup { destroy .f - set result -} {-class class Class Frame Frame} -test frame-3.3 {TkCreateFrame procedure} { +} -result {-class class Class Frame Frame} +test frame-3.3 {TkCreateFrame procedure} -setup { catch {destroy .t} toplevel .t wm geometry .t +0+0 - set result [.t configure -class] +} -body { + .t configure -class +} -cleanup { destroy .t - set result -} {-class class Class Toplevel Toplevel} +} -result {-class class Class Toplevel Toplevel} test frame-3.4 {TkCreateFrame procedure} { catch {destroy .t} toplevel .t -width 350 -class NewClass -bg black -visual default -height 90 @@ -311,141 +318,148 @@ test frame-3.8 {TkCreateFrame procedure} { option clear list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4] } {Silly #122334} -test frame-3.9 {TkCreateFrame procedure, -use option} unixOnly { +test frame-3.9 {TkCreateFrame procedure, -use option} -setup { catch {destroy .t} catch {destroy .x} +} -constraints unix -body { toplevel .t -container 1 -width 300 -height 120 wm geometry .t +0+0 toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green tkwait visibility .x - set result "[expr [winfo rootx .x] - [winfo rootx .t]] [expr [winfo rooty .x] - [winfo rooty .t]] [winfo width .t] [winfo height .t]" + list [expr {[winfo rootx .x] - [winfo rootx .t]}] \ + [expr {[winfo rooty .x] - [winfo rooty .t]}] \ + [winfo width .t] [winfo height .t] +} -cleanup { destroy .t - set result -} {0 0 140 300} -test frame-3.10 {TkCreateFrame procedure, -use option} unixOnly { +} -result {0 0 140 300} +test frame-3.10 {TkCreateFrame procedure, -use option} -setup { catch {destroy .t} catch {destroy .x} +} -constraints unix -body { toplevel .t -container 1 -width 300 -height 120 wm geometry .t +0+0 option add *x.use [winfo id .t] toplevel .x -width 140 -height 300 -bg green tkwait visibility .x - set result "[expr [winfo rootx .x] - [winfo rootx .t]] [expr [winfo rooty .x] - [winfo rooty .t]] [winfo width .t] [winfo height .t]" - destroy .t + list [expr {[winfo rootx .x] - [winfo rootx .t]}] \ + [expr {[winfo rooty .x] - [winfo rooty .t]}] \ + [winfo width .t] [winfo height .t] +} -cleanup { + destroy .t option clear - set result -} {0 0 140 300} +} -result {0 0 140 300} -# The tests below require specific display characteristics. Even so, -# they are non-portable: some machines don't seem to ever run out of +# The tests below require specific display characteristics (i.e. that +# they are run on a pseudocolor display of depth 8). Even so, they +# are non-portable: some machines don't seem to ever run out of # colors. -if {([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)} { +if {[testConstraint defaultPseudocolor8]} { eatColors .t1 - test frame-3.11 {TkCreateFrame procedure} {nonPortable} { - catch {destroy .t} - toplevel .t -width 300 -height 200 -bg #475601 - wm geometry .t +0+0 - update - colorsFree .t - } {0} - test frame-3.12 {TkCreateFrame procedure} {nonPortable} { - catch {destroy .t} - toplevel .t -width 300 -height 200 -bg #475601 -colormap new - wm geometry .t +0+0 - update - colorsFree .t - } {1} - test frame-3.13 {TkCreateFrame procedure} {nonPortable} { - catch {destroy .t} - option add *t.class Toplevel2 - option add *Toplevel2.colormap new - toplevel .t -width 300 -height 200 -bg #475601 - wm geometry .t +0+0 - update - option clear - colorsFree .t - } {1} - test frame-3.14 {TkCreateFrame procedure} {nonPortable} { - catch {destroy .t} - option add *t.class Toplevel3 - option add *Toplevel3.Colormap new - toplevel .t -width 300 -height 200 -bg #475601 -colormap new - wm geometry .t +0+0 - update - option clear - colorsFree .t - } {1} - test frame-3.15 {TkCreateFrame procedure, -use and -colormap} {unixOnly nonPortable} { - catch {destroy .t} - catch {destroy .x} - toplevel .t -container 1 -width 300 -height 120 - wm geometry .t +0+0 - toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green -colormap new - tkwait visibility .x - set result "[colorsFree .t] [colorsFree .x]" - destroy .t - set result - } {0 1} - test frame-3.16 {TkCreateFrame procedure} {nonPortable} { - catch {destroy .t} - toplevel .t -width 300 -height 200 -bg #475601 -visual default - wm geometry .t +0+0 - update - colorsFree .t - } {0} - test frame-3.17 {TkCreateFrame procedure} {nonPortable} { - catch {destroy .t} - toplevel .t -width 300 -height 200 -bg #475601 -visual default \ - -colormap new - wm geometry .t +0+0 - update - colorsFree .t - } {1} - if {[lsearch -exact [winfo visualsavailable .] {grayscale 8}] >= 0} { - test frame-3.18 {TkCreateFrame procedure} {nonPortable} { - catch {destroy .t} - toplevel .t -visual {grayscale 8} -width 300 -height 200 \ - -bg #434343 - wm geometry .t +0+0 - update - colorsFree .t 131 131 131 - } {1} - test frame-3.19 {TkCreateFrame procedure} {nonPortable} { - catch {destroy .t} - option add *t.class T4 - option add *T4.visual {grayscale 8} - toplevel .t -width 300 -height 200 -bg #434343 - wm geometry .t +0+0 - update - option clear - list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4] - } {1 {grayscale 8}} - test frame-3.20 {TkCreateFrame procedure} {nonPortable} { - catch {destroy .t} - set x ok - option add *t.class T5 - option add *T5.Visual {grayscale 8} - toplevel .t -width 300 -height 200 -bg #434343 - wm geometry .t +0+0 - update - option clear - list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4] - } {1 {grayscale 8}} - test frame-3.21 {TkCreateFrame procedure} {nonPortable} { - catch {destroy .t} - set x ok - toplevel .t -visual {grayscale 8} -width 300 -height 200 \ - -bg #434343 - wm geometry .t +0+0 - update - colorsFree .t 131 131 131 - } {1} - } +} +test frame-3.11 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { + catch {destroy .t} + toplevel .t -width 300 -height 200 -bg #475601 + wm geometry .t +0+0 + update + colorsFree .t +} {0} +test frame-3.12 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { + catch {destroy .t} + toplevel .t -width 300 -height 200 -bg #475601 -colormap new + wm geometry .t +0+0 + update + colorsFree .t +} {1} +test frame-3.13 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { + catch {destroy .t} + option add *t.class Toplevel2 + option add *Toplevel2.colormap new + toplevel .t -width 300 -height 200 -bg #475601 + wm geometry .t +0+0 + update + option clear + colorsFree .t +} {1} +test frame-3.14 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { + catch {destroy .t} + option add *t.class Toplevel3 + option add *Toplevel3.Colormap new + toplevel .t -width 300 -height 200 -bg #475601 -colormap new + wm geometry .t +0+0 + update + option clear + colorsFree .t +} {1} +test frame-3.15 {TkCreateFrame procedure, -use and -colormap} -setup { + catch {destroy .t} + catch {destroy .x} +} -constraints {defaultPseudocolor8 unix nonPortable} -body { + toplevel .t -container 1 -width 300 -height 120 + wm geometry .t +0+0 + toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green -colormap new + tkwait visibility .x + list [colorsFree .t] [colorsFree .x] +} -cleanup { + destroy .t +} -result {0 1} +test frame-3.16 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { + catch {destroy .t} + toplevel .t -width 300 -height 200 -bg #475601 -visual default + wm geometry .t +0+0 + update + colorsFree .t +} {0} +test frame-3.17 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { + catch {destroy .t} + toplevel .t -width 300 -height 200 -bg #475601 -visual default \ + -colormap new + wm geometry .t +0+0 + update + colorsFree .t +} {1} +test frame-3.18 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 nonPortable} { + catch {destroy .t} + toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 + wm geometry .t +0+0 + update + colorsFree .t 131 131 131 +} {1} +test frame-3.19 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 nonPortable} { + catch {destroy .t} + option add *t.class T4 + option add *T4.visual {grayscale 8} + toplevel .t -width 300 -height 200 -bg #434343 + wm geometry .t +0+0 + update + option clear + list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4] +} {1 {grayscale 8}} +test frame-3.20 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 nonPortable} { + catch {destroy .t} + set x ok + option add *t.class T5 + option add *T5.Visual {grayscale 8} + toplevel .t -width 300 -height 200 -bg #434343 + wm geometry .t +0+0 + update + option clear + list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4] +} {1 {grayscale 8}} +test frame-3.21 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 nonPortable} { + catch {destroy .t} + set x ok + toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 + wm geometry .t +0+0 + update + colorsFree .t 131 131 131 +} {1} +if {[testConstraint defaultPseudocolor8]} { destroy .t1 } -test frame-3.22 {TkCreateFrame procedure, default dimensions} { +test frame-3.22 {TkCreateFrame procedure, default dimensions} -setup { catch {destroy .t} +} -body { toplevel .t wm geometry .t +0+0 update @@ -454,20 +468,20 @@ test frame-3.22 {TkCreateFrame procedure, default dimensions} { pack .t.f update lappend result [winfo reqwidth .t.f] [winfo reqheight .t.f] +} -cleanup { destroy .t - set result -} {200 200 1 1} -test frame-3.23 {TkCreateFrame procedure} { +} -result {200 200 1 1} +test frame-3.23 {TkCreateFrame procedure} -setup { catch {destroy .f} - list [catch {frame .f -gorp glob} msg] $msg -} {1 {unknown option "-gorp"}} -test frame-3.24 {TkCreateFrame procedure} { +} -body { + frame .f -gorp glob +} -returnCodes error -result {unknown option "-gorp"} +test frame-3.24 {TkCreateFrame procedure} -setup { catch {destroy .t} - list [catch { - toplevel .t -width 300 -height 200 -colormap new -bogus option - wm geometry .t +0+0 - } msg] $msg -} {1 {unknown option "-bogus"}} +} -body { + toplevel .t -width 300 -height 200 -colormap new -bogus option + wm geometry .t +0+0 +} -returnCodes error -result {unknown option "-bogus"} test frame-4.1 {TkCreateFrame procedure} { catch {destroy .f} @@ -777,16 +791,16 @@ foreach test { {-text "any string" "any string" {} {}} {-width 32 32 badValue {bad screen distance "badValue"}} } { - set name [lindex $test 0] + lassign $test name goodValue goodResult badValue badResult test frame-13.$i {labelframe configuration options} { - .f configure $name [lindex $test 1] + .f configure $name $goodValue lindex [.f configure $name] 4 - } [lindex $test 2] + } $goodResult incr i - if {[lindex $test 3] != ""} { - test frame-13.$i {labelframe configuration options} { - list [catch {.f configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] + if {$badValue ne ""} { + test frame-13.$i {labelframe configuration options} -body { + .f configure $name $badValue + } -returnCodes error -result $badResult } .f configure $name [lindex [.f configure $name] 3] incr i @@ -796,7 +810,7 @@ destroy .f test frame-14.1 {labelframe labelwidget option} { # Test that label is moved in stacking order destroy .f .l - label .l -text Mupp + label .l -text Mupp -font {helvetica 8} labelframe .f -labelwidget .l pack .f frame .f.f -width 50 -height 50 @@ -897,5 +911,6 @@ rename eatColors {} rename colorsFree {} # cleanup -::tcltest::cleanupTests +cleanupTests return + |