Initial revision

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