diff options
Diffstat (limited to 'tests/frame.test')
| -rw-r--r-- | tests/frame.test | 617 |
1 files changed, 617 insertions, 0 deletions
diff --git a/tests/frame.test b/tests/frame.test new file mode 100644 index 0000000..c23d851 --- /dev/null +++ b/tests/frame.test @@ -0,0 +1,617 @@ +# This file is a Tcl script to test out the "frame" and "toplevel" +# commands of Tk. It is organized in the standard fashion for Tcl +# tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) frame.test 1.29 97/10/10 15:52:19 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + catch {destroy $i} +} +wm geometry . {} +raise . + +# eatColors -- +# Creates a toplevel window and allocates enough colors in it to +# use up all the slots in the colormap. +# +# Arguments: +# w - Name of toplevel window to create. + +proc eatColors {w} { + catch {destroy $w} + toplevel $w + wm geom $w +0+0 + canvas $w.c -width 400 -height 200 -bd 0 + pack $w.c + for {set y 0} {$y < 8} {incr y} { + for {set x 0} {$x < 40} {incr x} { + set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0] + $w.c create rectangle [expr 10*$x] [expr 20*$y] \ + [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ + -fill $color + } + } + update +} + +# colorsFree -- +# +# Returns 1 if there appear to be free colormap entries in a window, +# 0 otherwise. +# +# Arguments: +# w - Name of window in which to check. +# red, green, blue - Intensities to use in a trial color allocation +# to see if there are colormap entries free. + +proc colorsFree {w {red 31} {green 245} {blue 192}} { + set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] + expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \ + && ([lindex $vals 2]/256 == $blue) +} + +test frame-1.1 {frame configuration options} { + frame .f -class NewFrame + list [.f configure -class] [catch {.f configure -class Different} msg] $msg +} {{-class class Class Frame NewFrame} 1 {can't modify -class option after widget is created}} +catch {destroy .f} +test frame-1.2 {frame configuration options} { + list [catch {frame .f -colormap new} msg] $msg +} {0 .f} +catch {destroy .f} +test frame-1.3 {frame configuration options} { + list [catch {frame .f -visual default} msg] $msg +} {0 .f} +catch {destroy .f} +test frame-1.4 {frame configuration options} { + list [catch {frame .f -screen bogus} msg] $msg +} {1 {unknown option "-screen"}} +test frame-1.5 {frame configuration options} { + set result [list [catch {frame .f -container true} msg] $msg \ + [.f configure -container]] + destroy .f + set result +} {0 .f {-container container Container 0 1}} +test frame-1.6 {frame configuration options} { + list [catch {frame .f -container bogus} msg] $msg +} {1 {expected boolean value but got "bogus"}} +test frame-1.7 {frame configuration options} { + frame .f + set result [list [catch {.f configure -container 1} msg] $msg] + destroy .f + set result +} {1 {can't modify -container option after widget is created}} +frame .f +set i 8 +foreach test { + {-background #ff0000 #ff0000 non-existent + {unknown color name "non-existent"}} + {-bd 4 4 badValue {bad screen distance "badValue"}} + {-bg #00ff00 #00ff00 non-existent + {unknown color name "non-existent"}} + {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} + {-cursor arrow arrow badValue {bad cursor spec "badValue"}} + {-height 100 100 not_a_number {bad screen distance "not_a_number"}} + {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} + {-highlightcolor #123456 #123456 non-existent + {unknown color name "non-existent"}} + {-highlightthickness 6 6 badValue {bad screen distance "badValue"}} + {-relief ridge ridge badValue {bad relief type "badValue": must be flat, groove, raised, ridge, solid, or sunken}} + {-takefocus "any string" "any string" {} {}} + {-width 32 32 badValue {bad screen distance "badValue"}} +} { + set name [lindex $test 0] + test frame-1.$i {frame configuration options} { + .f configure $name [lindex $test 1] + lindex [.f configure $name] 4 + } [lindex $test 2] + 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]] + } + .f configure $name [lindex [.f configure $name] 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 + wm geometry .t +0+0 + list [.t configure -class] [catch {.t configure -class Another} msg] $msg +} {{-class class Class Toplevel NewClass} 1 {can't modify -class option after widget is created}} +test frame-2.2 {toplevel configuration options} { + catch {destroy .t} + toplevel .t -width 200 -height 100 -colormap new + wm geometry .t +0+0 + list [.t configure -colormap] [catch {.t configure -colormap .} msg] $msg +} {{-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 + 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}} +test frame-2.4 {toplevel configuration options} { + catch {destroy .t} + list [catch {toplevel .t -width 200 -height 100 -colormap bogus} msg] $msg +} {1 {bad window path name "bogus"}} +set default "[winfo visual .] [winfo depth .]" +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 + wm geometry .t +0+0 + list [.t configure -visual] [catch {.t configure -visual best} msg] $msg +} {{-visual visual Visual {} default} 1 {can't modify -visual option after widget is created}} +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.9 {toplevel configuration options} { + catch {destroy .t} + list [catch {toplevel .t -width 200 -height 100 -screen bogus} msg] $msg +} {1 {couldn't connect to display "bogus"}} +catch {destroy .t} +toplevel .t -width 300 -height 150 +wm geometry .t +0+0 +update +set i 8 +foreach test { + {-background #ff0000 #ff0000 non-existent + {unknown color name "non-existent"}} + {-bd 4 4 badValue {bad screen distance "badValue"}} + {-bg #00ff00 #00ff00 non-existent + {unknown color name "non-existent"}} + {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} + {-cursor arrow arrow badValue {bad cursor spec "badValue"}} + {-height 100 100 not_a_number {bad screen distance "not_a_number"}} + {-highlightcolor #123456 #123456 non-existent + {unknown color name "non-existent"}} + {-highlightthickness 3 3 badValue {bad screen distance "badValue"}} + {-relief ridge ridge badValue {bad relief type "badValue": must be flat, groove, raised, ridge, solid, or sunken}} + {-width 32 32 badValue {bad screen distance "badValue"}} +} { + set name [lindex $test 0] + test frame-2.$i {frame configuration options} { + .t configure $name [lindex $test 1] + lindex [.t configure $name] 4 + } [lindex $test 2] + incr i + if {[lindex $test 3] != ""} { + test frame-2.$i {frame configuration options} { + list [catch {.t configure $name [lindex $test 3]} msg] $msg + } [list 1 [lindex $test 4]] + } + .t configure $name [lindex [.t configure $name] 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} { + catch {destroy .f} + frame .f + set result [.f configure -class] + destroy .f + set result +} {-class class Class Frame Frame} +test frame-3.3 {TkCreateFrame procedure} { + catch {destroy .t} + toplevel .t + wm geometry .t +0+0 + set result [.t configure -class] + destroy .t + set 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 + wm geometry .t +0+0 + update + list [lindex [.t configure -width] 4] \ + [lindex [.t configure -background] 4] \ + [lindex [.t configure -height] 4] +} {350 black 90} + +# Be sure that the -class, -colormap, and -visual options are processed +# before configuring the widget. + +test frame-3.5 {TkCreateFrame procedure} { + catch {destroy .f} + option add *NewFrame.background #123456 + frame .f -class NewFrame + option clear + lindex [.f configure -background] 4 +} {#123456} +test frame-3.6 {TkCreateFrame procedure} { + catch {destroy .f} + option add *NewFrame.background #123456 + frame .f -class NewFrame + option clear + lindex [.f configure -background] 4 +} {#123456} +test frame-3.7 {TkCreateFrame procedure} { + catch {destroy .f} + option add *NewFrame.background #332211 + option add *f.class NewFrame + frame .f + option clear + list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4] +} {NewFrame #332211} +test frame-3.8 {TkCreateFrame procedure} { + catch {destroy .f} + option add *Silly.background #122334 + option add *f.Class Silly + frame .f + option clear + list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4] +} {Silly #122334} +test frame-3.9 {TkCreateFrame procedure, -use option} unixOnly { + 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 + 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 + set result +} {0 0 140 300} +test frame-3.10 {TkCreateFrame procedure, -use option} unixOnly { + catch {destroy .t} + catch {destroy .x} + 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 + option clear + set 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)} { + 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} + } + destroy .t1 +} +test frame-3.22 {TkCreateFrame procedure, default dimensions} { + catch {destroy .t} + toplevel .t + wm geometry .t +0+0 + update + set result "[winfo reqwidth .t] [winfo reqheight .t]" + frame .t.f -bg red + pack .t.f + update + lappend result [winfo reqwidth .t.f] [winfo reqheight .t.f] + destroy .t + set result +} {200 200 1 1} +test frame-3.23 {TkCreateFrame procedure} { + catch {destroy .f} + list [catch {frame .f -gorp glob} msg] $msg +} {1 {unknown option "-gorp"}} +test frame-3.24 {TkCreateFrame procedure} { + 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"}} + +test frame-4.1 {TkCreateFrame procedure} { + catch {destroy .f} + catch {frame .f -gorp glob} + winfo exists .f +} 0 +test frame-4.2 {TkCreateFrame procedure} { + catch {destroy .f} + list [frame .f -width 200 -height 100] [winfo exists .f] +} {.f 1} + +catch {destroy .f} +frame .f -highlightcolor black +test frame-5.1 {FrameWidgetCommand procedure} { + list [catch .f msg] $msg +} {1 {wrong # args: should be ".f option ?arg arg ...?"}} +test scale-5.2 {FrameWidgetCommand procedure, cget option} { + list [catch {.f cget} msg] $msg +} {1 {wrong # args: should be ".f cget option"}} +test scale-5.3 {FrameWidgetCommand procedure, cget option} { + list [catch {.f cget a b} msg] $msg +} {1 {wrong # args: should be ".f cget option"}} +test scale-5.4 {FrameWidgetCommand procedure, cget option} { + list [catch {.f cget -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test scale-5.5 {FrameWidgetCommand procedure, cget option} { + .f cget -highlightcolor +} {black} +test scale-5.6 {FrameWidgetCommand procedure, cget option} { + list [catch {.f cget -screen} msg] $msg +} {1 {unknown option "-screen"}} +test scale-5.7 {FrameWidgetCommand procedure, cget option} { + catch {destroy .t} + toplevel .t + catch {.t cget -screen} +} {0} +catch {destroy .t} +test frame-5.8 {FrameWidgetCommand procedure, configure option} { + llength [.f configure] +} {16} +test frame-5.9 {FrameWidgetCommand procedure, configure option} { + list [catch {.f configure -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test frame-5.10 {FrameWidgetCommand procedure, configure option} { + list [catch {.f configure -gorp bogus} msg] $msg +} {1 {unknown option "-gorp"}} +test frame-5.11 {FrameWidgetCommand procedure, configure option} { + list [catch {.f configure -width 200 -height} msg] $msg +} {1 {value for "-height" missing}} +test frame-5.12 {FrameWidgetCommand procedure} { + list [catch {.f swizzle} msg] $msg +} {1 {bad option "swizzle": must be cget or configure}} + +test frame-6.1 {ConfigureFrame procedure} { + catch {destroy .f} + frame .f -width 150 + list [winfo reqwidth .f] [winfo reqheight .f] +} {150 1} +test frame-6.2 {ConfigureFrame procedure} { + catch {destroy .f} + frame .f -height 97 + list [winfo reqwidth .f] [winfo reqheight .f] +} {1 97} +test frame-6.3 {ConfigureFrame procedure} { + catch {destroy .f} + frame .f + set result {} + lappend result [winfo reqwidth .f] [winfo reqheight .f] + .f configure -width 100 -height 180 + lappend result [winfo reqwidth .f] [winfo reqheight .f] + .f configure -width 0 -height 0 + lappend result [winfo reqwidth .f] [winfo reqheight .f] +} {1 1 100 180 100 180} + +test frame-7.1 {FrameEventProc procedure} { + frame .frame2 + set result [info commands .frame2] + destroy .frame2 + lappend result [info commands .frame2] +} {.frame2 {}} +test frame-7.2 {FrameEventProc procedure} { + eval destroy [winfo children .] + frame .f1 -bg #543210 + rename .f1 .f2 + set x {} + lappend x [winfo children .] + lappend x [.f2 cget -bg] + destroy .f1 + lappend x [info command .f*] [winfo children .] +} {.f1 #543210 {} {}} + +test frame-8.1 {FrameCmdDeletedProc procedure} { + eval destroy [winfo children .] + frame .f1 + rename .f1 {} + list [info command .f*] [winfo children .] +} {{} {}} +test frame-8.2 {FrameCmdDeletedProc procedure} { + eval destroy [winfo children .] + toplevel .f1 -menu .m + wm geometry .f1 +0+0 + update + rename .f1 {} + update + list [info command .f*] [winfo children .] +} {{} {}} +test frame-8.3 {FrameCmdDeletedProc procedure} { + eval destroy [winfo children .] + toplevel .f1 -menu .m + wm geometry .f1 +0+0 + menu .m + update + rename .f1 {} + update + set result [list [info command .f*] [winfo children .]] + eval destroy [winfo children .] + set result +} {{} .m} + +test frame-9.1 {MapFrame procedure} { + catch {destroy .t} + toplevel .t -width 100 -height 400 + wm geometry .t +0+0 + set result [winfo ismapped .t] + update idletasks + lappend result [winfo ismapped .t] +} {0 1} +test frame-9.2 {MapFrame procedure} { + catch {destroy .t} + toplevel .t -width 100 -height 400 + wm geometry .t +0+0 + destroy .t + update + winfo exists .t +} {0} +test frame-9.3 {MapFrame procedure, window deleted while mapping} { + toplevel .t2 -width 200 -height 200 + wm geometry .t2 +0+0 + tkwait visibility .t2 + catch {destroy .t} + toplevel .t -width 100 -height 400 + wm geometry .t +0+0 + frame .t2.f -width 50 -height 50 + bind .t2.f <Configure> {destroy .t} + pack .t2.f -side top + update idletasks + winfo exists .t +} {0} + +set l [interp hidden] +eval destroy [winfo children .] + +test frame-10.1 {frame widget vs hidden commands} { + catch {destroy .t} + frame .t + interp hide {} .t + destroy .t + list [winfo children .] [interp hidden] +} [list {} $l] + +test frame-11.1 {TkInstallFrameMenu} { + catch {destroy .t} + menu .m1 + .m1 add cascade -menu .m1.system + menu .m1.system -tearoff 0 + .m1.system add command -label foo + list [toplevel .t -menu .m1] [destroy .m1] [destroy .t] +} {.t {} {}} +test frame-11.2 {TkInstallFrameMenu - frame renamed} { + catch {destroy .t} + catch {rename foo {}} + menu .m1 + .m1 add cascade -menu .m1.system + menu .m1.system -tearoff 0 + .m1.system add command -label foo + toplevel .t + list [rename .t foo] [destroy .t] [destroy foo] [destroy .m1] +} {{} {} {} {}} + + +catch {destroy .f} +rename eatColors {} +rename colorsFree {} |