917 lines
31 KiB
Plaintext
917 lines
31 KiB
Plaintext
# 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.
|
|
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
|
# All rights reserved.
|
|
|
|
package require tcltest 2.1
|
|
eval tcltest::configure $argv
|
|
tcltest::loadTestedCommands
|
|
|
|
# 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} {
|
|
frame .f -colormap new
|
|
list [.f configure -colormap] [catch {.f configure -colormap .} msg] $msg
|
|
} {{-colormap colormap Colormap {} new} 1 {can't modify -colormap option after widget is created}}
|
|
catch {destroy .f}
|
|
test frame-1.3 {frame configuration options} {
|
|
frame .f -visual default
|
|
list [.f configure -visual] [catch {.f configure -visual best} msg] $msg
|
|
} {{-visual visual Visual {} default} 1 {can't modify -visual option after widget is created}}
|
|
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}}
|
|
test frame-1.8 {frame configuration options} {
|
|
# Make sure all options can be set to the default value
|
|
frame .f
|
|
set opts {}
|
|
foreach opt [.f configure] {
|
|
if {[llength $opt] == 5} {
|
|
lappend opts [lindex $opt 0] [lindex $opt 4]
|
|
}
|
|
}
|
|
eval frame .g $opts
|
|
destroy .f .g
|
|
} {}
|
|
|
|
frame .f
|
|
set i 9
|
|
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"}}
|
|
{-padx 3 3 badValue {bad screen distance "badValue"}}
|
|
{-pady 4 4 badValue {bad screen distance "badValue"}}
|
|
{-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
|
|
{-takefocus "any string" "any string" {} {}}
|
|
{-width 32 32 badValue {bad screen distance "badValue"}}
|
|
} {
|
|
lassign $test opt goodValue goodResult badValue badResult
|
|
test frame-1.$i {frame configuration options} {
|
|
.f configure $opt $goodValue
|
|
lindex [.f configure $opt] 4
|
|
} $goodResult
|
|
incr i
|
|
if {$badValue ne ""} {
|
|
test frame-1.$i {frame configuration options} -body {
|
|
.f configure $opt $badValue
|
|
} -returnCodes error -result $badResult
|
|
}
|
|
.f configure $opt [lindex [.f configure $opt] 3]
|
|
incr i
|
|
}
|
|
destroy .f
|
|
|
|
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 .]"
|
|
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
|
|
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}}
|
|
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
|
|
} {1 {couldn't connect to display "bogus"}}
|
|
test frame-2.10 {toplevel configuration options} {
|
|
catch {destroy .t}
|
|
catch {destroy .x}
|
|
toplevel .t -container 1 -width 300 -height 120
|
|
wm geometry .t +0+0
|
|
set result [list \
|
|
[catch {toplevel .x -container 1 -use [winfo id .t]} msg] $msg]
|
|
destroy .t .x
|
|
set result
|
|
} {1 {A window cannot have both the -use and the -container option set.}}
|
|
test frame-2.11 {toplevel configuration options} {
|
|
# Make sure all options can be set to the default value
|
|
toplevel .f
|
|
set opts {}
|
|
foreach opt [.f configure] {
|
|
if {[llength $opt] == 5} {
|
|
lappend opts [lindex $opt 0] [lindex $opt 4]
|
|
}
|
|
}
|
|
eval toplevel .g $opts
|
|
destroy .f .g
|
|
} {}
|
|
|
|
catch {destroy .t}
|
|
toplevel .t -width 300 -height 150
|
|
wm geometry .t +0+0
|
|
update
|
|
set i 12
|
|
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"}}
|
|
{-padx 3 3 badValue {bad screen distance "badValue"}}
|
|
{-pady 4 4 badValue {bad screen distance "badValue"}}
|
|
{-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
|
|
{-width 32 32 badValue {bad screen distance "badValue"}}
|
|
} {
|
|
lassign $test opt goodValue goodResult badValue badResult
|
|
test frame-2.$i {toplevel configuration options} {
|
|
.t configure $opt $goodValue
|
|
lindex [.t configure $opt] 4
|
|
} $goodResult
|
|
incr i
|
|
if {$badValue ne ""} {
|
|
test frame-2.$i {toplevel configuration options} -body {
|
|
.t configure $opt $badValue
|
|
} -returnCodes error -result $badResult
|
|
}
|
|
.t configure $opt [lindex [.t configure $opt] 3]
|
|
incr i
|
|
}
|
|
|
|
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
|
|
} -body {
|
|
.f configure -class
|
|
} -cleanup {
|
|
destroy .f
|
|
} -result {-class class Class Frame Frame}
|
|
test frame-3.3 {TkCreateFrame procedure} -setup {
|
|
catch {destroy .t}
|
|
toplevel .t
|
|
wm geometry .t +0+0
|
|
} -body {
|
|
.t configure -class
|
|
} -cleanup {
|
|
destroy .t
|
|
} -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} -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
|
|
list [expr {[winfo rootx .x] - [winfo rootx .t]}] \
|
|
[expr {[winfo rooty .x] - [winfo rooty .t]}] \
|
|
[winfo width .t] [winfo height .t]
|
|
} -cleanup {
|
|
destroy .t
|
|
} -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
|
|
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
|
|
} -result {0 0 140 300}
|
|
|
|
# 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 {[testConstraint defaultPseudocolor8]} {
|
|
eatColors .t1
|
|
}
|
|
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} -setup {
|
|
catch {destroy .t}
|
|
} -body {
|
|
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]
|
|
} -cleanup {
|
|
destroy .t
|
|
} -result {200 200 1 1}
|
|
test frame-3.23 {TkCreateFrame procedure} -setup {
|
|
catch {destroy .f}
|
|
} -body {
|
|
frame .f -gorp glob
|
|
} -returnCodes error -result {unknown option "-gorp"}
|
|
test frame-3.24 {TkCreateFrame procedure} -setup {
|
|
catch {destroy .t}
|
|
} -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}
|
|
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 frame-5.2 {FrameWidgetCommand procedure, cget option} {
|
|
list [catch {.f cget} msg] $msg
|
|
} {1 {wrong # args: should be ".f cget option"}}
|
|
test frame-5.3 {FrameWidgetCommand procedure, cget option} {
|
|
list [catch {.f cget a b} msg] $msg
|
|
} {1 {wrong # args: should be ".f cget option"}}
|
|
test frame-5.4 {FrameWidgetCommand procedure, cget option} {
|
|
list [catch {.f cget -gorp} msg] $msg
|
|
} {1 {unknown option "-gorp"}}
|
|
test frame-5.5 {FrameWidgetCommand procedure, cget option} {
|
|
.f cget -highlightcolor
|
|
} {black}
|
|
test frame-5.6 {FrameWidgetCommand procedure, cget option} {
|
|
list [catch {.f cget -screen} msg] $msg
|
|
} {1 {unknown option "-screen"}}
|
|
test frame-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]
|
|
} {18}
|
|
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-5.13 {FrameWidgetCommand procedure, configure option} {
|
|
llength [. configure]
|
|
} {21}
|
|
|
|
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} {
|
|
deleteWindows
|
|
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} {
|
|
deleteWindows
|
|
frame .f1
|
|
rename .f1 {}
|
|
list [info command .f*] [winfo children .]
|
|
} {{} {}}
|
|
test frame-8.2 {FrameCmdDeletedProc procedure} {
|
|
deleteWindows
|
|
toplevel .f1 -menu .m
|
|
wm geometry .f1 +0+0
|
|
update
|
|
rename .f1 {}
|
|
update
|
|
list [info command .f*] [winfo children .]
|
|
} {{} {}}
|
|
#
|
|
# This one fails with the dash-patch!!!! Still don't know why :-(
|
|
#
|
|
#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]
|
|
deleteWindows
|
|
|
|
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]
|
|
} {{} {} {} {}}
|
|
|
|
test frame-12.1 {FrameWorldChanged procedure} {
|
|
# Test -bd -padx and -pady
|
|
destroy .f
|
|
frame .f -borderwidth 2 -padx 3 -pady 4
|
|
place .f -x 0 -y 0 -width 40 -height 40
|
|
pack [frame .f.f] -fill both -expand 1
|
|
update
|
|
set result [list [winfo x .f.f] [winfo y .f.f] \
|
|
[winfo width .f.f] [winfo height .f.f]]
|
|
destroy .f
|
|
set result
|
|
} {5 6 30 28}
|
|
test frame-12.2 {FrameWorldChanged procedure} {
|
|
# Test all -labelanchor positions
|
|
destroy .f
|
|
set font {helvetica 12}
|
|
labelframe .f -highlightthickness 1 -bd 3 -padx 1 -pady 2 -font $font \
|
|
-text "Mupp"
|
|
set fh [expr {[font metrics $font -linespace] + 2 - 3}]
|
|
set fw [expr {[font measure $font "Mupp"] + 2 - 3}]
|
|
if {$fw < 0} {set fw 0}
|
|
if {$fh < 0} {set fh 0}
|
|
place .f -x 0 -y 0 -width 100 -height 100
|
|
pack [frame .f.f] -fill both -expand 1
|
|
|
|
set result {}
|
|
foreach lp {nw n ne en e es se s sw ws w wn} {
|
|
.f configure -labelanchor $lp
|
|
update
|
|
set expx 5
|
|
set expy 6
|
|
set expw 90
|
|
set exph 88
|
|
switch -glob $lp {
|
|
n* {incr expy $fh ; incr exph -$fh}
|
|
s* {incr exph -$fh}
|
|
w* {incr expx $fw ; incr expw -$fw}
|
|
e* {incr expw -$fw}
|
|
}
|
|
lappend result [expr {\
|
|
[winfo x .f.f] == $expx && [winfo y .f.f] == $expy &&\
|
|
[winfo width .f.f] == $expw && [winfo height .f.f] == $exph}]
|
|
}
|
|
destroy .f
|
|
set result
|
|
} {1 1 1 1 1 1 1 1 1 1 1 1}
|
|
test frame-12.3 {FrameWorldChanged procedure} {
|
|
# Check reaction on font change
|
|
destroy .f
|
|
font create myfont -family courier -size 10
|
|
labelframe .f -font myfont -text Mupp
|
|
place .f -x 0 -y 0 -width 40 -height 40
|
|
pack [frame .f.f] -fill both -expand 1
|
|
update
|
|
set h1 [font metrics myfont -linespace]
|
|
set y1 [winfo y .f.f]
|
|
font configure myfont -size 20
|
|
update
|
|
set h2 [font metrics myfont -linespace]
|
|
set y2 [winfo y .f.f]
|
|
destroy .f
|
|
font delete myfont
|
|
expr {($h2 - $h1) - ($y2 - $y1)}
|
|
} {0}
|
|
|
|
test frame-13.1 {labelframe configuration options} {
|
|
labelframe .f -class NewFrame
|
|
list [.f configure -class] [catch {.f configure -class Different} msg] $msg
|
|
} {{-class class Class Labelframe NewFrame} 1 {can't modify -class option after widget is created}}
|
|
catch {destroy .f}
|
|
test frame-13.2 {labelframe configuration options} {
|
|
list [catch {labelframe .f -colormap new} msg] $msg
|
|
} {0 .f}
|
|
catch {destroy .f}
|
|
test frame-13.3 {labelframe configuration options} {
|
|
list [catch {labelframe .f -visual default} msg] $msg
|
|
} {0 .f}
|
|
catch {destroy .f}
|
|
test frame-13.4 {labelframe configuration options} {
|
|
list [catch {labelframe .f -screen bogus} msg] $msg
|
|
} {1 {unknown option "-screen"}}
|
|
test frame-13.5 {labelframe configuration options} {
|
|
set result [list [catch {labelframe .f -container true} msg] $msg \
|
|
[.f configure -container]]
|
|
destroy .f
|
|
set result
|
|
} {0 .f {-container container Container 0 1}}
|
|
test frame-13.6 {labelframe configuration options} {
|
|
list [catch {labelframe .f -container bogus} msg] $msg
|
|
} {1 {expected boolean value but got "bogus"}}
|
|
test frame-13.7 {labelframe configuration options} {
|
|
labelframe .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}}
|
|
labelframe .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"}}
|
|
{-fg #0000ff #0000ff non-existent
|
|
{unknown color name "non-existent"}}
|
|
{-font {courier 8} {courier 8} {} {}}
|
|
{-foreground #ff0000 #ff0000 non-existent
|
|
{unknown color name "non-existent"}}
|
|
{-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"}}
|
|
{-labelanchor se se badValue {bad labelanchor "badValue": must be e, en, es, n, ne, nw, s, se, sw, w, wn, or ws}}
|
|
{-padx 3 3 badValue {bad screen distance "badValue"}}
|
|
{-pady 4 4 badValue {bad screen distance "badValue"}}
|
|
{-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
|
|
{-takefocus "any string" "any string" {} {}}
|
|
{-text "any string" "any string" {} {}}
|
|
{-width 32 32 badValue {bad screen distance "badValue"}}
|
|
} {
|
|
lassign $test name goodValue goodResult badValue badResult
|
|
test frame-13.$i {labelframe configuration options} {
|
|
.f configure $name $goodValue
|
|
lindex [.f configure $name] 4
|
|
} $goodResult
|
|
incr i
|
|
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
|
|
}
|
|
destroy .f
|
|
|
|
test frame-14.1 {labelframe labelwidget option} {
|
|
# Test that label is moved in stacking order
|
|
destroy .f .l
|
|
label .l -text Mupp -font {helvetica 8}
|
|
labelframe .f -labelwidget .l
|
|
pack .f
|
|
frame .f.f -width 50 -height 50
|
|
pack .f.f
|
|
update
|
|
set res [list [winfo children .] [winfo width .f] \
|
|
[expr {[winfo height .f] - [winfo height .l]}]]
|
|
destroy .f .l
|
|
set res
|
|
} {{.f .l} 54 52}
|
|
test frame-14.2 {labelframe labelwidget option} {
|
|
# Test the labelframe's reaction if the label is destroyed
|
|
destroy .f .l
|
|
label .l -text Aratherlonglabel
|
|
labelframe .f -labelwidget .l
|
|
pack .f
|
|
label .f.l -text Mupp
|
|
pack .f.l
|
|
update
|
|
set res [list [.f cget -labelwidget]]
|
|
lappend res [expr {[winfo width .f] - [winfo width .l]}]
|
|
destroy .l
|
|
lappend res [.f cget -labelwidget]
|
|
update
|
|
lappend res [expr {[winfo width .f] - [winfo width .f.l]}]
|
|
destroy .f
|
|
set res
|
|
} {.l 12 {} 4}
|
|
test frame-14.3 {labelframe labelwidget option} {
|
|
# Test the labelframe's reaction if the label is stolen
|
|
destroy .f .l
|
|
label .l -text Aratherlonglabel
|
|
labelframe .f -labelwidget .l
|
|
pack .f
|
|
label .f.l -text Mupp
|
|
pack .f.l
|
|
update
|
|
set res [list [.f cget -labelwidget]]
|
|
lappend res [expr {[winfo width .f] - [winfo width .l]}]
|
|
pack .l
|
|
lappend res [.f cget -labelwidget]
|
|
update
|
|
lappend res [expr {[winfo width .f] - [winfo width .f.l]}]
|
|
destroy .f .l
|
|
set res
|
|
} {.l 12 {} 4}
|
|
test frame-14.4 {labelframe labelwidget option} {
|
|
# Test the label's reaction if the labelframe is destroyed
|
|
destroy .f .l
|
|
label .l -text Mupp
|
|
labelframe .f -labelwidget .l
|
|
pack .f
|
|
update
|
|
set res [list [winfo manager .l]]
|
|
destroy .f
|
|
lappend res [winfo manager .l]
|
|
destroy .l
|
|
set res
|
|
} {labelframe {}}
|
|
test frame-14.5 {labelframe labelwidget option} {
|
|
# Test that the labelframe reacts on changes in label
|
|
destroy .f .l
|
|
label .l -text Aratherlonglabel
|
|
labelframe .f -labelwidget .l
|
|
pack .f
|
|
label .f.l -text Mupp
|
|
pack .f.l
|
|
update
|
|
set first [winfo width .f]
|
|
set res [expr {[winfo width .f] - [winfo width .l]}]
|
|
.l configure -text Shorter
|
|
update
|
|
lappend res [expr {[winfo width .f] - [winfo width .l]}]
|
|
lappend res [expr {[winfo width .f] < $first}]
|
|
.l configure -text Alotlongerthananytimebefore
|
|
update
|
|
lappend res [expr {[winfo width .f] - [winfo width .l]}]
|
|
lappend res [expr {[winfo width .f] > $first}]
|
|
destroy .f .l
|
|
set res
|
|
} {12 12 1 12 1}
|
|
test frame-14.6 {labelframe labelwidget option} {
|
|
# Destroying a labelframe with a child label caused a crash
|
|
# when not handling mapping of the label correctly.
|
|
# This test does not test anything directly, it's just ment
|
|
# to catch if the same mistake is made again.
|
|
destroy .f
|
|
labelframe .f
|
|
pack .f
|
|
label .f.l -text Mupp
|
|
.f configure -labelwidget .f.l
|
|
update
|
|
destroy .f
|
|
} {}
|
|
|
|
catch {destroy .f}
|
|
rename eatColors {}
|
|
rename colorsFree {}
|
|
|
|
# cleanup
|
|
cleanupTests
|
|
return
|
|
|