button.test

linux系统下的音频通信

# This file is a Tcl script to test labels, buttons, checkbuttons, and
# radiobuttons in Tk (i.e., all the widgets defined in tkButton.c).  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: @(#) button.test 1.39 97/07/31 10:19:02

if {[lsearch [image types] test] < 0} {
    puts "This application hasn't been compiled with the \"test\""
    puts "image, so I can't run this test.  Are you sure you're using"
    puts "tktest instead of wish?"
    return
}

if {[info procs test] != "test"} {
    source defs
}

foreach i [winfo children .] {
    destroy $i
}
wm geometry . {}
raise .

proc bogusTrace args {
    error "trace aborted"
}
catch {unset value}
catch {unset value2}

# Create entries in the option database to be sure that geometry options
# like border width have predictable values.

option add *Button.borderWidth 2
option add *Button.highlightThickness 2
option add *Button.font {Helvetica -12 bold}

eval image delete [image names]
image create test image1
label .l -text Label
button .b -text Button
checkbutton .c -text Checkbutton
radiobutton .r -text Radiobutton
pack .l .b .c .r
update
set i 1
foreach test {
    {-activebackground #012345 #012345 non-existent
	    {unknown color name "non-existent"}}
    {-activeforeground #ff0000 #ff0000 non-existent
	    {unknown color name "non-existent"}}
    {-anchor nw nw bogus {bad anchor position "bogus": must be n, ne, e, se, s, sw, w, nw, or center}}
    {-background #ff0000 #ff0000 non-existent
	    {unknown color name "non-existent"}}
    {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}
    {-bd 4 4 badValue {bad screen distance "badValue"}}
    {-bitmap questhead questhead badValue {bitmap "badValue" not defined}}
    {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
    {-command "set x" {set x} {} {}}
    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
    {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}}
    {-fg #110022 #110022 bogus {unknown color name "bogus"}}
    {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist}}
    {-foreground #110022 #110022 bogus {unknown color name "bogus"}}
    {-height 18 18 20.0 {expected integer but got "20.0"}}
    {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
    {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}}
    {-highlightthickness 18 18 badValue {bad screen distance "badValue"}}
    {-image image1 image1 bogus {image "bogus" doesn't exist}}
    {-indicatoron yes 1 no_way {expected boolean value but got "no_way"}}
    {-justify right right bogus {bad justification "bogus": must be left, right, or center}}
    {-offvalue lousy lousy {} {}}
    {-offvalue fantastic fantastic {} {}}
    {-padx 12 12 420x {bad screen distance "420x"}}
    {-pady 12 12 420x {bad screen distance "420x"}}
    {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
    {-selectcolor #110022 #110022 bogus {unknown color name "bogus"}}
    {-selectimage image1 image1 bogus {image "bogus" doesn't exist}}
    {-state normal normal bogus {bad state value "bogus": must be normal, active, or disabled}}
    {-takefocus "any string" "any string" {} {}}
    {-text "Sample text" {Sample text} {} {}}
    {-textvariable i i {} {}}
    {-underline 5 5 3p {expected integer but got "3p"}}
    {-width 402 402 3p {expected integer but got "3p"}}
    {-wraplength 100 100 6x {bad screen distance "6x"}}
} {
    set name [lindex $test 0]
    test button-1.$i {configuration options} {
	.c configure $name [lindex $test 1]
	lindex [.c configure $name] 4
    } [lindex $test 2]
    incr i
    if {[lindex $test 3] != ""} {
	test button-1.$i {configuration options} {
	    list [catch {.c configure $name [lindex $test 3]} msg] $msg
	} [list 1 [lindex $test 4]]
    }
    .c configure $name [lindex [.c configure $name] 3]
    incr i
}
test button-1.$i {configuration options} {
    .c configure -selectcolor {}
} {}
incr i
# the following tests only work on buttons, not checkbuttons
test button-1.$i {configuration options} {
    .b configure -default active
    lindex [.b configure -default] 4
} active
incr i
test button-1.$i {configuration options} {
    .b configure -default normal
    lindex [.b configure -default] 4
} normal
incr i
test button-1.$i {configuration options} {
    .b configure -default disabled
    lindex [.b configure -default] 4
} disabled
incr i
test button-1.$i {configuration options} {
    .b configure -default active
    lindex [.b configure -default] 3
} disabled
incr i
test button-1.$i {configuration options} {
    list [catch {.b configure -default no_way} msg] $msg
} {1 {bad -default value "no_way": must be normal, active, or disabled}}

set i 1
foreach check {
    {-activebackground 1 0 0 0}
    {-activeforeground 1 0 0 0}
    {-anchor 0 0 0 0}
    {-background 0 0 0 0}
    {-bd 0 0 0 0}
    {-bg 0 0 0 0}
    {-bitmap 0 0 0 0}
    {-borderwidth 0 0 0 0}
    {-command 1 0 0 0}
    {-cursor 0 0 0 0}
    {-default 1 0 1 1}
    {-disabledforeground 1 0 0 0}
    {-fg 0 0 0 0}
    {-font 0 0 0 0}
    {-foreground 0 0 0 0}
    {-height 0 0 0 0}
    {-image 0 0 0 0}
    {-indicatoron 1 1 0 0}
    {-offvalue 1 1 0 1}
    {-onvalue 1 1 0 1}
    {-padx 0 0 0 0}
    {-pady 0 0 0 0}
    {-relief 0 0 0 0}
    {-selectcolor 1 1 0 0}
    {-selectimage 1 1 0 0}
    {-state 1 0 0 0}
    {-text 0 0 0 0}
    {-textvariable 0 0 0 0}
    {-value 1 1 1 0}
    {-variable 1 1 0 0}
    {-width 0 0 0 0}
} {
    test button-2.$i {label-specific options} "
	catch {.l configure [lindex $check 0]}
    " [lindex $check 1]
    incr i
    test button-2.$i {button-specific options} "
	catch {.b configure [lindex $check 0]}
    " [lindex $check 2]
    incr i
    test button-2.$i {checkbutton-specific options} "
	catch {.c configure [lindex $check 0]}
    " [lindex $check 3]
    incr i
    test button-2.$i {radiobutton-specific options} "
	catch {.r configure [lindex $check 0]}
    " [lindex $check 4]
    incr i
}

test button-3.1 {ButtonCreate procedure} {
    list [catch {button} msg] $msg
} {1 {wrong # args: should be "button pathName ?options?"}}
test button-3.2 {ButtonCreate procedure} {
    catch {destroy .x}
    label .x
    winfo class .x
} {Label}
test button-3.3 {ButtonCreate procedure} {
    catch {destroy .x}
    button .x
    winfo class .x
} {Button}
test button-3.4 {ButtonCreate procedure} {
    catch {destroy .x}
    checkbutton .x
    winfo class .x
} {Checkbutton}
test button-3.5 {ButtonCreate procedure} {
    catch {destroy .x}
    radiobutton .x
    winfo class .x
} {Radiobutton}
rename button gorp
test button-3.6 {ButtonCreate procedure} {
    catch {destroy .x}
    gorp .x
    winfo class .x
} {Button}
rename gorp button
test button-3.7 {ButtonCreate procedure} {
    list [catch {button foo} msg] $msg
} {1 {bad window path name "foo"}}
test button-3.8 {ButtonCreate procedure} {
    catch {destroy .x}
    list [catch {button .x -gorp foo} msg] $msg [winfo exists .x]
} {1 {unknown option "-gorp"} 0}

test button-4.1 {ButtonWidgetCmd procedure} {
    list [catch {.b} msg] $msg
} {1 {wrong # args: should be ".b option ?arg arg ...?"}}
test button-4.2 {ButtonWidgetCmd procedure, "cget" option} {
    list [catch {.b c} msg] $msg
} {1 {bad option "c": must be cget, configure, flash, or invoke}}
test button-4.3 {ButtonWidgetCmd procedure, "cget" option} {
    list [catch {.b cget a b} msg] $msg
} {1 {wrong # args: should be ".b cget option"}}
test button-4.4 {ButtonWidgetCmd procedure, "cget" option} {
    list [catch {.b cget -gorp} msg] $msg
} {1 {unknown option "-gorp"}}
test button-4.5 {ButtonWidgetCmd procedure, "cget" option} {
    .b configure -highlightthickness 3
    .b cget -highlightthickness
} {3}
test button-4.6 {ButtonWidgetCmd procedure, "cget" option} {
    list [catch {.l cget -disabledforeground} msg] $msg
} {1 {unknown option "-disabledforeground"}}
test button-4.7 {ButtonWidgetCmd procedure, "cget" option} {
    catch {.b cget -disabledforeground}
} {0}
test button-4.8 {ButtonWidgetCmd procedure, "cget" option} {
    list [catch {.b cget -variable} msg] $msg
} {1 {unknown option "-variable"}}
test button-4.9 {ButtonWidgetCmd procedure, "cget" option} {
    catch {.c cget -variable}
} {0}
test button-4.10 {ButtonWidgetCmd procedure, "cget" option} {
    list [catch {.c cget -value} msg] $msg
} {1 {unknown option "-value"}}
test button-4.11 {ButtonWidgetCmd procedure, "cget" option} {
    catch {.r cget -value}
} {0}
test button-4.12 {ButtonWidgetCmd procedure, "cget" option} {
    list [catch {.r cget -onvalue} msg] $msg
} {1 {unknown option "-onvalue"}}
test button-4.13 {ButtonWidgetCmd procedure, "configure" option} {
    llength [.c configure]
} {36}
test button-4.14 {ButtonWidgetCmd procedure, "configure" option} {
    list [catch {.b configure -gorp} msg] $msg
} {1 {unknown option "-gorp"}}
test button-4.15 {ButtonWidgetCmd procedure, "configure" option} {
    list [catch {.b co -bg #ffffff -fg} msg] $msg
} {1 {value for "-fg" missing}}
test button-4.16 {ButtonWidgetCmd procedure, "configure" option} {
    .b configure -fg #123456
    .b configure -bg #654321
    lindex [.b configure -fg] 4
} {#123456}
.c configure -variable value -onvalue 1 -offvalue 0
.r configure -variable value2 -value red
test button-4.17 {ButtonWidgetCmd procedure, "deselect" option} {
    list [catch {.c deselect foo} msg] $msg
} {1 {wrong # args: should be ".c deselect"}}
test button-4.18 {ButtonWidgetCmd procedure, "deselect" option} {
    list [catch {.l deselect} msg] $msg
} {1 {bad option "deselect": must be cget or configure}}
test button-4.19 {ButtonWidgetCmd procedure, "deselect" option} {
    list [catch {.b deselect} msg] $msg
} {1 {bad option "deselect": must be cget, configure, flash, or invoke}}
test button-4.20 {ButtonWidgetCmd procedure, "deselect" option} {
    set value 1
    .c d
    set value
} {0}
test button-4.21 {ButtonWidgetCmd procedure, "deselect" option} {
    set value2 green
    .r deselect
    set value2
} {green}
test button-4.22 {ButtonWidgetCmd procedure, "deselect" option} {
    set value2 red
    .r deselect
    set value2
} {}
test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} {
    set value 1
    trace variable value w bogusTrace
    set result [list [catch {.c deselect} msg] $msg $errorInfo $value]
    trace vdelete value w bogusTrace
    set result
} {1 {can't set "value": trace aborted} {can't set "value": trace aborted
    while executing
".c deselect"} 0}
test button-4.24 {ButtonWidgetCmd procedure, "deselect" option} {
    set value2 red
    trace variable value2 w bogusTrace
    set result [list [catch {.r deselect} msg] $msg $errorInfo $value2]
    trace vdelete value2 w bogusTrace
    set result
} {1 {can't set "value2": trace aborted} {can't set "value2": trace aborted
    while executing
".r deselect"} {}}
test button-4.25 {ButtonWidgetCmd procedure, "flash" option} {
    list [catch {.b flash foo} msg] $msg
} {1 {wrong # args: should be ".b flash"}}
test button-4.26 {ButtonWidgetCmd procedure, "flash" option} {
    list [catch {.l flash} msg] $msg
} {1 {bad option "flash": must be cget or configure}}
test button-4.27 {ButtonWidgetCmd procedure, "flash" option} {
    list [catch {.b flash} msg] $msg
} {0 {}}
test button-4.28 {ButtonWidgetCmd procedure, "flash" option} {
    list [catch {.c flash} msg] $msg
} {0 {}}
test button-4.29 {ButtonWidgetCmd procedure, "flash" option} {
    list [catch {.r f} msg] $msg
} {0 {}}
test button-4.30 {ButtonWidgetCmd procedure, "invoke" option} {
    list [catch {.b invoke foo} msg] $msg
} {1 {wrong # args: should be ".b invoke"}}
test button-4.31 {ButtonWidgetCmd procedure, "invoke" option} {
    list [catch {.l invoke} msg] $msg
} {1 {bad option "invoke": must be cget or configure}}
test button-4.32 {ButtonWidgetCmd procedure, "invoke" option} {
    .b configure -command {set x invoked}
    set x "not invoked"
    .b invoke
    set x
} {invoked}
test button-4.33 {ButtonWidgetCmd procedure, "invoke" option} {
    .b configure -command {set x invoked} -state disabled
    set x "not invoked"
    .b invoke
    set x
} {not invoked}
test button-4.34 {ButtonWidgetCmd procedure, "invoke" option} {
    set value bogus
    .c configure -command {set x invoked} -variable value -onvalue 1 \
	    -offvalue 0
    set x "not invoked"
    .c invoke
    list $x $value
} {invoked 1}
test button-4.35 {ButtonWidgetCmd procedure, "invoke" option} {
    set value2 green
    .r configure -command {set x invoked} -variable value2 -value red
    set x "not invoked"
    .r i
    list $x $value2
} {invoked red}
test button-4.36 {ButtonWidgetCmd procedure, "select" option} {
    list [catch {.l select} msg] $msg
} {1 {bad option "select": must be cget or configure}}
test button-4.37 {ButtonWidgetCmd procedure, "select" option} {
    list [catch {.b select} msg] $msg
} {1 {bad option "select": must be cget, configure, flash, or invoke}}
test button-4.38 {ButtonWidgetCmd procedure, "select" option} {
    list [catch {.c select foo} msg] $msg
} {1 {wrong # args: should be ".c select"}}
test button-4.39 {ButtonWidgetCmd procedure, "select" option} {
    set value bogus
    .c configure -command {} -variable value -onvalue lovely -offvalue 0
    .c s
    set value
} {lovely}
test button-4.40 {ButtonWidgetCmd procedure, "select" option} {
    set value2 green
    .r configure -command {} -variable value2 -value red
    .r select
    set value2
} {red}
test button-4.41 {ButtonWidgetCmd procedure, "select" option} {
    set value2 yellow
    trace variable value2 w bogusTrace
    set result [list [catch {.r select} msg] $msg $errorInfo $value2]
    trace vdelete value2 w bogusTrace
    set result
} {1 {can't set "value2": trace aborted} {can't set "value2": trace aborted
    while executing
".r select"} red}
test button-4.42 {ButtonWidgetCmd procedure, "toggle" option} {
    list [catch {.l toggle} msg] $msg
} {1 {bad option "toggle": must be cget or configure}}
test button-4.43 {ButtonWidgetCmd procedure, "toggle" option} {
    list [catch {.b toggle} msg] $msg
} {1 {bad option "toggle": must be cget, configure, flash, or invoke}}
test button-4.44 {ButtonWidgetCmd procedure, "toggle" option} {
    list [catch {.r toggle} msg] $msg
} {1 {bad option "toggle": must be cget, configure, deselect, flash, invoke, or select}}
test button-4.45 {ButtonWidgetCmd procedure, "toggle" option} {
    list [catch {.c toggle foo} msg] $msg
} {1 {wrong # args: should be ".c toggle"}}
test button-4.46 {ButtonWidgetCmd procedure, "toggle" option} {
    set value bogus
    .c configure -command {} -variable value -onvalue sunshine -offvalue rain