diff options
Diffstat (limited to 'tests/frame.test')
| -rw-r--r-- | tests/frame.test | 349 |
1 files changed, 181 insertions, 168 deletions
diff --git a/tests/frame.test b/tests/frame.test index 22f4091..41307fe 100644 --- a/tests/frame.test +++ b/tests/frame.test @@ -7,12 +7,20 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: frame.test,v 1.9 2003/07/16 23:16:52 pspjuth Exp $ +# RCS: @(#) $Id: frame.test,v 1.10 2004/05/23 17:34:48 dkf Exp $ package require tcltest 2.1 eval tcltest::configure $argv tcltest::loadTestedCommands +testConstraint haveDISPLAY [info exists env(DISPLAY)] +testConstraint edibleColors [expr { + ([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8) +}] +testConstraint haveGrayscale8 [expr { + [lsearch -exact [winfo visualsavailable .] {grayscale 8}] >= 0 +}] + # eatColors -- # Creates a toplevel window and allocates enough colors in it to # use up all the slots in the colormap. @@ -120,23 +128,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 @@ -176,15 +183,13 @@ 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 + 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.9 {toplevel configuration options} { catch {destroy .t} list [catch {toplevel .t -width 200 -height 100 -screen bogus} msg] $msg @@ -234,38 +239,40 @@ 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} test frame-3.4 {TkCreateFrame procedure} { catch {destroy .t} @@ -310,141 +317,147 @@ 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 unixOnly -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 unixOnly -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 # colors. -if {([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)} { +if {[testConstraint edibleColors]} { 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} {edibleColors 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} {edibleColors 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} {edibleColors 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} {edibleColors 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 {edibleColors unixOnly 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} {edibleColors 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} {edibleColors 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} {edibleColors 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} {edibleColors 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} {edibleColors 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} {edibleColors 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 edibleColors]} { 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 @@ -453,20 +466,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} @@ -776,16 +789,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 |