frame.test

linux系统下的音频通信

# 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} {