menu.test

linux系统下的音频通信

# This file is a Tcl script to test menus in Tk.  It is
# organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995-1997 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: @(#) menu.test 1.43 97/10/28 13:51:13

if {[lsearch [image types] test] < 0} {
    puts "This application hasn't been compiled with the \"test\" image"
    puts "type, 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
}

if {$tcl_platform(platform) == "windows" && ![info exists INTERACTIVE]} {
    puts " Some tests were skipped because they could not be performed"
    puts " automatically on this platform. If you wish to execute them"
    puts " interactively, set the TCL variable INTERACTIVE and re-run"
    puts " the test."
    set testConfig(menuInteractive) 0
} else {
    set testConfig(menuInteractive) 1
}

proc deleteWindows {} {
    foreach i [winfo children .] {
    	catch [destroy $i]
    }
}

deleteWindows
wm geometry . {}
raise .

test menu-1.1 {Tk_MenuCmd procedure} {
    list [catch menu msg] $msg
} {1 {wrong # args: should be "menu pathName ?options?"}}
test menu-1.2 {Tk_MenuCmd procedure} {
    list [catch "menu bogus" msg] $msg
} {1 {bad window path name "bogus"}}
test menu-1.3 {Tk_MenuCmd procedure} {
    list [catch "menu .m1 foo" msg] $msg
} {1 {unknown option "foo"}}
test menu-1.4 {Tk_MenuCmd procedure} {
    catch {destroy .m1}
    list [catch {menu .m1} msg] $msg [destroy .m1]
} {0 .m1 {}}
test menu-1.5 {Tk_MenuCmd - creating menubar} {
    catch {destroy .m1}
    menu .m1
    .m1 add cascade -label Test -menu ""
    list [. configure -menu .m1] [. configure -menu ""] [destroy .m1]
} {{} {} {}}
test menu-1.6 {Tk_MenuCmd procedure menu ref no cascade} {
    catch {destroy .t2}
    catch {destroy .m1}
    toplevel .t2 -menu .m1
    wm geometry .t2 +0+0
    list [catch {menu .m1} msg] $msg [destroy .m1 .t2]
} {0 .m1 {}}
test menu-1.7 {Tk_MenuCmd procedure one clone cascade} {
    catch {destroy .m1}
    catch {destroy .m2}
    catch {destroy .t2}
    toplevel .t2 -menu .m1
    wm geometry .t2 +0+0
    menu .m1
    .m1 add cascade -menu .m2
    list [catch {menu .m2} msg] $msg [destroy .t2 .m1 .m2]
} {0 .m2 {}}
test menu-1.8 {Tk_MenuCmd procedure two clone cascades} {
    catch {destroy .m1}
    catch {destroy .t2}
    catch {destroy .t3}
    catch {destroy .m2}
    menu .m1
    .m1 add cascade -menu .m2
    toplevel .t2 -menu .m1
    wm geometry .t2 +0+0
    toplevel .t3 -menu .m1
    wm geometry .t3 +0+0
    list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .m1 .m2]
} {0 .m2 {}}
test menu-1.9 {Tk_MenuCmd procedure two clone cascades different order} {
    catch {destroy .t2}
    catch {destroy .m1}
    catch {destroy .t3}
    catch {destroy .m2}
    toplevel .t2 -menu .m1
    wm geometry .t2 +0+0
    menu .m1
    .m1 add cascade -menu .m2
    toplevel .t3 -menu .m1
    wm geometry .t3 +0+0
    list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .m1 .m2]
} {0 .m2 {}}
test menu-1.10 {Tk_MenuCmd procedure two clone cascades menus last} {
    catch {destroy .t2}
    catch {destroy .t3}
    catch {destroy .m1}
    catch {destroy .m2}
    toplevel .t2 -menu .m1
    wm geometry .t2 +0+0
    toplevel .t3 -menu .m1
    wm geometry .t3 +0+0
    menu .m1
    .m1 add cascade -menu .m2
    list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .m1 .m2]
} {0 .m2 {}}
test menu-1.11 {Tk_MenuCmd procedure three clones cascades} {
    catch {destroy .t2}
    catch {destroy .t3}
    catch {destroy .t4}
    catch {destroy .m1}
    catch {destroy .m2}
    toplevel .t2 -menu .m1
    wm geometry .t2 +0+0
    toplevel .t3 -menu .m1
    wm geometry .t3 +0+0
    toplevel .t4 -menu .m1
    wm geometry .t4 +0+0
    menu .m1
    .m1 add cascade -menu .m2
    list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .t4 .m1 .m2]
} {0 .m2 {}}
test menu-1.12 {Tk_MenuCmd procedure} {
    catch {destroy .t2}
    catch {destroy .m1}
    toplevel .t2 -menu .m1
    wm geometry .t2 +0+0
    list [catch {menu .m1} msg] $msg [destroy .t2 .m1]
} {0 .m1 {}}
test menu-1.13 {Tk_MenuCmd procedure} {
    catch {destroy .t2}
    catch {destroy .t3}
    catch {destroy .m1}
    toplevel .t2 -menu .m1
    wm geometry .t2 +0+0
    toplevel .t3 -menu .m1
    wm geometry .t3 +0+0
    list [catch {menu .m1} msg] $msg [destroy .t2 .t3 .m1]
} {0 .m1 {}}
test menu-1.14 {Tk_MenuCmd procedure} {
    catch {destroy .t2}
    catch {destroy .t3}
    catch {destroy .t4}
    catch {destroy .m1}
    toplevel .t2 -menu .m1
    wm geometry .t2 +0+0
    toplevel .t3 -menu .m1
    wm geometry .t3 +0+0
    toplevel .t4 -menu .m1
    wm geometry .t4 +0+0
    list [catch {menu .m1} msg] $msg [destroy .t2 .t3 .t4 .m1]
} {0 .m1 {}}

catch {destroy .m1}
menu .m1
set i 1
foreach test {
    {-activebackground #012345 #012345 non-existent
	    {unknown color name "non-existent"}}
    {-activeborderwidth 1.3 1 badValue {bad screen distance "badValue"}}
    {-activeforeground #ff0000 #ff0000 non-existent
	    {unknown color name "non-existent"}}
    {-background #ff0000 #ff0000 non-existent
	    {unknown color name "non-existent"}}
    {-bg #110022 #110022 bogus {unknown color name "bogus"}}
    {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
    {-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 -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* 
	    -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* {}
	    {font "" doesn't exist}}
    {-foreground #110022 #110022 bogus {unknown color name "bogus"}}
    {-postcommand "any old string" "any old string" {} {}}
    {-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"}}
    {-takefocus "any string" "any string" {} {}}
    {-tearoff 0 0}
    {-tearoff 1 1}
    {-tearoffcommand "any old string" "any old string" {} {}}
} {
    set name [lindex $test 0]
    test menu-2.$i {configuration options} {
	.m1 configure $name [lindex $test 1]
	lindex [.m1 configure $name] 4
    } [lindex $test 2]
    incr i
    if {[lindex $test 3] != ""} {
	test menu-2.$i {configuration options} {
	    list [catch {.m1 configure $name [lindex $test 3]} msg] $msg
	} [list 1 [lindex $test 4]]
    }
    .m1 configure $name [lindex [.m1 configure $name] 3]
    incr i
}
destroy .m1

# We need to test all of the options with all of the different types of
# menu entries. The following code sets up .m1 with 6 items. It then
# runs through the big table below it.
# index 0 is tearoff, 1 command, 2 cascade, 3 separator, 4 checkbutton, 
# 5 radiobutton

menu .m1
.m1 add command -label "command"
menu .m2
.m2 add command -label "test"
.m1 add cascade -label "cascade" -menu .m2
.m1 add separator
.m1 add checkbutton -label "checkbutton" -variable check -onvalue on -offvalue off
.m1 add radiobutton -label "radiobutton" -variable radio
image create photo image1 -file [file join $tk_library demos images earth.gif]

foreach test {
    {-activebackground 
        {{#012345 
            {{unknown option "-activebackground"} #012345 #012345 
            {unknown option "-activebackground"} #012345 #012345
            }
        }
        {non-existent 
            {{unknown option "-activebackground"} 
	    {unknown color name "non-existent"}
	    {unknown color name "non-existent"}
	    {unknown option "-activebackground"}
	    {unknown color name "non-existent"}
	    {unknown color name "non-existent"}
	    }
	}}
    }
    {-activeforeground
    	{{#ff0000 
    	    {{unknown option "-activeforeground"}
	    #ff0000 #ff0000 {unknown option "-activeforeground"} #ff0000 #ff0000
	    }
	}
	{non-existent
	    {{unknown option "-activeforeground"} 
	    {unknown color name "non-existent"}
	    {unknown color name "non-existent"}
	    {unknown option "-activeforeground"}
	    {unknown color name "non-existent"}
	    {unknown color name "non-existent"}
	    }
	}}
    }
    {-accelerator
    	{{"Ctrl+S" 
    	    {{unknown option "-accelerator"}
	    "Ctrl+S" "Ctrl+S" {unknown option "-accelerator"} 
	    "Ctrl+S" "Ctrl+S"
	    }
	}}
    }
    {-background
    	{{#ff0000 
    	    {#ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000
	    }
	}
	{non-existent
	    {{unknown color name "non-existent"} 
	    {unknown color name "non-existent"}
	    {unknown color name "non-existent"}
	    {unknown color name "non-existent"}
	    {unknown color name "non-existent"}
	    {unknown color name "non-existent"}
	    }
	}}
    }
    {-bitmap
    	{{questhead 
    	    {{unknown option "-bitmap"} questhead questhead 
    	    {unknown option "-bitmap"} questhead questhead
	    }
	}
	{badValue
	    {{unknown option "-bitmap"} 
	    {bitmap "badValue" not defined}
	    {bitmap "badValue" not defined}
	    {unknown option "-bitmap"}
	    {bitmap "badValue" not defined}
	    {bitmap "badValue" not defined}
	    }
	}}
    }
    {-columnbreak
	{{1
	    {{unknown option "-columnbreak"} 1 1 {unknown option "-columnbreak"} 1 1}
	}}
    }
    {-command
    	{{beep 
    	    {{unknown option "-command"} beep beep 
    	    {unknown option "-command"} beep beep
	    }
	}}
    }
    {-font
    	{{-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* 
    	    {{unknown option "-font"}
    	    -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
    	    -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* 
    	    {unknown option "-font"} 
    	    -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
    	    -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
	    }
	}
	{{kill rock stars}
	    {{unknown option "-font"}
	    {expected integer but got "rock"}
	    {expected integer but got "rock"}
	    {unknown option "-font"}
	    {expected integer but got "rock"}
	    {expected integer but got "rock"}
	    }
	}}
    }
    {-foreground
    	{{#110022 
    	    {{unknown option "-foreground"} #110022 #110022 
    	    {unknown option "-foreground"} #110022 #110022
	    }
	}
	{non-existent
	    {{unknown option "-foreground"} 
	    {unknown color name "non-existent"}
	    {unknown color name "non-existent"}
	    {unknown option "-foreground"}
	    {unknown color name "non-existent"}
	    {unknown color name "non-existent"}
	    }
	}}
    }
    {-image
    	{{image1 
    	    {{unknown option "-image"} image1 image1 
    	    {unknown option "-image"} image1 image1
	    }
	}
	{bogus
	    {{unknown option "-image"} 
	    {image "bogus" doesn't exist}
	    {image "bogus" doesn't exist}
	    {unknown option "-image"}
	    {image "bogus" doesn't exist}
	    {image "bogus" doesn't exist}
	    }
	}
	{""
	    {{unknown option "-image"}
	    {}
	    {}
	    {unknown option "-image"}
	    {}
	    {}
	    }
	}}
    }
    {-indicatoron
    	{{1 
    	    {{unknown option "-indicatoron"}
    	    {unknown option "-indicatoron"}
    	    {unknown option "-indicatoron"} 
    	    {unknown option "-indicatoron"} 1 1
	    }
	}}
    }
    {-label
    	{{test 
    	    {{unknown option "-label"} test test 
    	    {unknown option "-label"} test test
	    }
	}}
    }
    {-menu
    	{{.m2 
    	    {{unknown option "-menu"}
    	    {unknown option "-menu"} .m2 
    	    {unknown option "-menu"}
    	    {unknown option "-menu"}
    	    {unknown option "-menu"}
	    }
	}}
    }
    {-offvalue
    	{{off
    	    {{unknown option "-offvalue"} 
    	    {unknown option "-offvalue"}
	    {unknown option "-offvalue"}
    	    {unknown option "-offvalue"}
    	    off
    	    {unknown option "-offvalue"}
	    }
	}}
    }
    {-onvalue
    	{{on
    	    {{unknown option "-onvalue"}
    	    {unknown option "-onvalue"}
    	    {unknown option "-onvalue"}