Initial revision

1 files changed, 546 insertions, 0 deletions

diff --git a/tests/menuDraw.test b/tests/menuDraw.test
new file mode 100644
index 0000000..291d2a2
--- /dev/null
+++ b/tests/menuDraw.test
@@ -0,0 +1,546 @@
+# This file is a Tcl script to test drawing of menus in Tk.  It is
+# organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1996-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: @(#) menuDraw.test 1.11 97/06/24 13:50:34
+
+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
+}
+
+proc deleteWindows {} {
+    foreach i [winfo children .] {
+    	catch [destroy $i]
+    }
+}
+
+deleteWindows
+wm geometry . {}
+raise .
+
+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
+}
+
+test menuDraw-1.1 {TkMenuInitializeDrawingFields} {
+    catch {destroy .m1}
+    list [menu .m1] [destroy .m1]
+} {.m1 {}}
+
+test menuDraw-2.1 {TkIntializeMenuEntryDrawingFields} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add command] [destroy .m1]
+} {{} {}}
+
+test menuDraw-3.1 {TkMenuFreeDrawOptions} {
+    catch {destroy .m1}
+    menu .m1
+    list [destroy .m1]
+} {{}}
+
+test menuDraw-4.1 {TkMenuEntryFreeDrawOptions} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "This is a test"
+    list [destroy .m1]
+} {{}}
+test menuDraw-4.2 {TkMenuEntryFreeDrawOptions} {
+	catch {destroy .m1}
+	menu .m1
+	.m1 add checkbutton -label "This is a test." -font "Courier 12" -activeforeground red -background green -selectcolor purple
+	list [destroy .m1]
+} {{}}
+
+test menuDraw-5.1 {TkMenuConfigureDrawOptions - new menu} {
+    catch {destroy .m1}
+    list [menu .m1] [destroy .m1]
+} {.m1 {}}
+test menuDraw-5.2 {TkMenuConfigureDrawOptions - old menu} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 configure -fg red] [destroy .m1]
+} {{} {}}
+test menuDraw-5.3 {TkMenuConfigureDrawOptions - no disabledFg} {
+	catch {destroy .m1}
+	list [menu .m1 -disabledforeground ""] [destroy .m1]
+} {.m1 {}}	
+
+test menuDraw-6.1 {TkMenuConfigureEntryDrawOptions - no tkfont specified} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add command -label "foo"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.2 {TkMenuConfigureEntryDrawOptions - tkfont specified} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add command -label "foo" -font "Courier 12"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.3 {TkMenuConfigureEntryDrawOptions - active state - wrong entry} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo"
+    list [.m1 entryconfigure 1 -state active] [destroy .m1]
+} {{} {}}
+test menuDraw-6.4 {TkMenuConfigureEntryDrawOptions - active state - correct entry} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo"
+    .m1 activate 1
+    list [.m1 entryconfigure 1 -state active] [destroy .m1]
+} {{} {}}
+test menuDraw-6.5 {TkMenuConfigureEntryDrawOptions - deactivate entry} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo"
+    .m1 activate 1
+    list [.m1 entryconfigure 1 -state normal] [destroy .m1]
+} {{} {}}
+test menuDraw-6.6 {TkMenuConfigureEntryDrawOptions - bad state} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo"
+    list [catch {.m1 entryconfigure 1 -state foo} msg] $msg [destroy .m1]
+} {1 {bad state value "foo": must be normal, active, or disabled} {}}
+test menuDraw-6.7 {TkMenuConfigureEntryDrawOptions - tkfont specified} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add command -label "foo" -font "Courier 12"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.8 {TkMenuConfigureEntryDrawOptions - border specified} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add command -label "foo" -background "red"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.9 {TkMenuConfigureEntryDrawOptions - foreground specified} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add command -label "foo" -foreground "red"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.10 {TkMenuConfigureEntryDrawOptions - activeBorder specified} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add command -label "foo" -activebackground "red"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.11 {TkMenuConfigureEntryDrawOptions - activeforeground specified} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add command -label "foo" -activeforeground "red"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.12 {TkMenuConfigureEntryDrawOptions - selectcolor specified} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add radiobutton -label "foo" -selectcolor "red"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.13 {TkMenuConfigureEntryDrawOptions - textGC disposal} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo" -font "Helvetica 12"
+    list [.m1 entryconfigure 1 -font "Courier 12"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.14 {TkMenuConfigureEntryDrawOptions - activeGC disposal} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo" -activeforeground "red"
+    list [.m1 entryconfigure 1 -activeforeground "green"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.15 {TkMenuConfigureEntryDrawOptions - disabledGC disposal} {
+    catch {destroy .m1}
+    menu .m1 -disabledforeground "red"
+    .m1 add command -label "foo"
+    list [.m1 configure -disabledforeground "green"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.16 {TkMenuConfigureEntryDrawOptions - indicatorGC disposal} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add radiobutton -label "foo" -selectcolor "red"
+    list [.m1 entryconfigure 1 -selectcolor "green"] [destroy .m1]
+} {{} {}}
+
+test menuDraw-7.1 {TkEventuallyRecomputeMenu} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "This is a long label"
+    set tearoff [tkTearOffMenu .m1]
+    update idletasks
+    list [.m1 entryconfigure 1 -label "foo"] [destroy .m1]
+} {{} {}}
+test menuDraw-7.2 {TkEventuallyRecomputeMenu - update pending} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "This is a long label"
+    set tearoff [tkTearOffMenu .m1]
+    list [.m1 entryconfigure 1 -label "foo"] [destroy .m1]
+} {{} {}}
+
+
+test menuDraw-8.1 {TkRecomputeMenu} {menuInteractive} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 configure -postcommand [.m1 add command -label foo]
+    .m1 add command -label "Hit ESCAPE to make this menu go away."
+    list [.m1 post 0 0] [destroy .m1]
+} {{} {}}
+
+
+test menuDraw-9.1 {TkEventuallyRedrawMenu - entry test} {
+    catch {destroy .m1}
+    catch {unset foo}
+    menu .m1
+    set foo 0
+    .m1 add radiobutton -variable foo -label test
+    tkTearOffMenu .m1
+    update idletasks
+    list [set foo test] [destroy .m1] [unset foo]
+} {test {} {}}
+test menuDraw-9.2 {TkEventuallyRedrawMenu - whole menu} {
+    catch {destroy .m1}
+    menu .m1
+    list [catch {tkTearOffMenu .m1}] [destroy .m1]
+} {0 {}}
+
+# Don't know how to test when window has been deleted and ComputeMenuGeometry
+# gets called.
+test menuDraw-10.1 {ComputeMenuGeometry - menubar} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label test
+    . configure -menu .m1
+    list [update idletasks] [. configure -menu ""] [destroy .m1]
+} {{} {} {}}
+test menuDraw-10.2 {ComputeMenuGeometry - non-menubar} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label test
+    list [update idletasks] [destroy .m1]
+} {{} {}}
+test menuDraw-10.3 {ComputeMenuGeometry - Resize necessary} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label test
+    list [update idletasks] [destroy .m1]
+} {{} {}}
+test menuDraw-10.4 {ComputeMenuGeometry - resize not necessary} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label test
+    update idletasks
+    .m1 entryconfigure 1 -label test
+    list [update idletasks] [destroy .m1]
+} {{} {}}
+
+test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} {
+    catch {destroy .m1}
+    catch {eval image delete [image names]}
+    image create test image1
+    image create test image2
+    menu .m1
+    .m1 add checkbutton -image image1 -selectimage image2
+    .m1 invoke 1
+    set tearoff [tkTearOffMenu .m1 40 40]
+    update idletasks
+    list [image delete image2] [destroy .m1] [eval image delete [image names]]
+} {{} {} {}}
+test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} {
+    catch {destroy .m1}
+    catch {eval image delete [image names]}
+    image create test image1
+    image create test image2
+    menu .m1
+    .m1 add checkbutton -image image1 -selectimage image2
+    .m1 invoke 1
+    set tearoff [tkTearOffMenu .m1 40 40]
+    list [image delete image2] [destroy .m1] [eval image delete [image names]]
+} {{} {} {}}
+test menuDraw-11.3 {TkMenuSelectImageProc - entry not selected} {
+    catch {destroy .m1}
+    catch {eval image delete [image names]}
+    image create test image1
+    image create test image2
+    menu .m1
+    .m1 add checkbutton -image image1 -selectimage image2
+    set tearoff [tkTearOffMenu .m1 40 40]
+    update idletasks
+    list [image delete image2] [destroy .m1] [eval image delete [image names]]
+} {{} {} {}}
+
+#Don't know how to test missing tkwin in DisplayMenu
+test menuDraw-12.1 {DisplayMenu - menubar background} {unixOnly} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add cascade -label foo -menu .m2
+    . configure -menu .m1
+    list [update] [. configure -menu ""] [destroy .m1]
+} {{} {} {}}
+test menuDraw-12.2 {Display menu - no entries} {
+    catch {destroy .m1}
+    menu .m1
+    set tearoff [tkTearOffMenu .m1 40 40]
+    list [update] [destroy .m1]
+} {{} {}}
+test menuDraw-12.3 {DisplayMenu - one entry} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label foo
+    set tearoff [tkTearOffMenu .m1 40 40]
+    list [update] [destroy .m1]
+} {{} {}}
+test menuDraw-12.4 {DisplayMenu - two entries} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "one"
+    .m1 add command -label "two"
+    set tearoff [tkTearOffMenu .m1 40 40]
+    list [update] [destroy .m1]
+} {{} {}}
+test menuDraw.12.5 {DisplayMenu - two columns - first bigger} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "one"
+    .m1 add command -label "two"
+    .m1 add command -label "three" -columnbreak 1
+    set tearoff [tkTearOffMenu .m1 40 40]
+    list [update] [destroy .m1]
+} {{} {}}
+test menuDraw-12.5 {DisplayMenu - two column - second  bigger} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "one"
+    .m1 add command -label "two" -columnbreak 1
+    .m1 add command -label "three"
+    set tearoff [tkTearOffMenu .m1 40 40]
+    list [update] [destroy .m1]
+} {{} {}}
+test menuDraw.12.7 {DisplayMenu - three columns} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "one"
+    .m1 add command -label "two" -columnbreak 1
+    .m1 add command -label "three"
+    .m1 add command -label "four"
+    .m1 add command -label "five"
+    .m1 add command -label "six"
+    set tearoff [tkTearOffMenu .m1 40 40]
+    list [update] [destroy .m1]
+} {{} {}}
+test menuDraw-12.6 {Display menu - testing for extra space and menubars} {unixOnly} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add cascade -label foo
+    . configure -menu .m1
+    list [update] [. configure -menu ""] [destroy .m1]
+} {{} {} {}}
+test menuDraw-12.7 {Display menu - extra space at end of menu} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add cascade -label foo
+    set tearoff [tkTearOffMenu .m1 40 40]
+    wm geometry $tearoff 200x100
+    list [update] [destroy .m1]
+} {{} {}}
+
+test menuDraw-13.1 {TkMenuEventProc - Expose} {
+    catch {destroy .m1}
+    catch {destroy .m2}
+    menu .m1
+    .m1 add command -label "one"
+    menu .m2
+    .m2 add command -label "two"
+    set tearoff1 [tkTearOffMenu .m1 40 40]
+    set tearoff2 [tkTearOffMenu .m2 40 40]
+    list [raise $tearoff2] [update] [destroy .m1] [destroy .m2]
+} {{} {} {} {}}
+test menuDraw-13.2 {TkMenuEventProc - ConfigureNotify} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo"
+    set tearoff [tkTearOffMenu .m1 40 40]
+    list [wm geometry $tearoff 200x100] [update] [destroy .m1]
+} {{} {} {}}
+test menuDraw-13.3 {TkMenuEventProc - ActivateNotify} {macOnly} {
+    catch {destroy .t2}
+    toplevel .t2 -menu .t2.m1
+    menu .t2.m1
+    .t2.m1 add command -label foo
+    tkTearOffMenu .t2.m1 40 40
+    list [catch {update} msg] $msg [destroy .t2]
+} {0 {} {}}
+# Testing deletes is hard, and I am going to do my best. Don't know how
+# to test the case where we have already cleared the tkwin field in the
+# menuPtr.
+test menuDraw-13.4 {TkMenuEventProc - simple delete} {
+    catch {destroy .m1}
+    menu .m1
+    list [destroy .m1]
+} {{}}
+test menuDraw-13.5 {TkMenuEventProc - nothing pending} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label foo
+    update idletasks
+    list [destroy .m1]
+} {{}}
+
+test menuDraw-14.1 {TkMenuImageProc} {
+    catch {destroy .m1}
+    catch {image delete image1}
+    menu .m1
+    image create test image1
+    .m1 add command -image image1
+    update idletasks
+    list [image delete image1] [destroy .m1]
+} {{} {}}
+test menuDraw-14.2 {TkMenuImageProc} {
+    catch {destroy .m1}
+    catch {image delete image1}
+    menu .m1
+    image create test image1
+    .m1 add command -image image1
+    list [image delete image1] [destroy .m1]
+} {{} {}}
+
+test menuDraw-15.1 {TkPostTearoffMenu - Basic posting} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo"
+    list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1]
+} {0 {}}
+test menuDraw-15.2 {TkPostTearoffMenu - Deactivation} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo" -state active
+    set tearoff [tkTearOffMenu .m1 40 40]
+    list [$tearoff index active] [destroy .m1]
+} {none {}}
+test menuDraw-15.3 {TkPostTearoffMenu - post command} {
+    catch {destroy .m1}
+    catch {unset foo}
+    menu .m1 -postcommand "set foo .m1"
+    .m1 add command -label "foo"
+    list [catch {tkTearOffMenu .m1 40 40}] [set foo] [unset foo] [destroy .m1]
+} {0 .m1 {} {}}
+test menuDraw-15.4 {TkPostTearoffMenu - post command deleting the menu} {
+    catch {destroy .m1}
+    menu .m1 -postcommand "destroy .m1"
+    .m1 add command -label "foo"
+    list [catch {tkTearOffMenu .m1 40 40} msg] $msg [winfo exists .m1]
+} {0 {} 0}
+test menuDraw-15.5 {TkPostTearoffMenu - tearoff at edge of screen} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo"
+    set height [winfo screenheight .m1]
+    list [catch {tkTearOffMenu .m1 40 $height}] [destroy .m1]
+} {0 {}}
+test menuDraw-15.6 {TkPostTearoffMenu - tearoff off right} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo"
+    set width [winfo screenwidth .m1]
+    list [catch {tkTearOffMenu .m1 $width 40}] [destroy .m1]
+} {0 {}}
+
+
+test menuDraw-16.1 {TkPostSubmenu} {unixOnly} {
+    catch {destroy .m1}
+    catch {destroy .m2}
+    menu .m1
+    .m1 add cascade -label test -menu .m2
+    menu .m2
+    .m2 add command -label "Hit ESCAPE to make this menu go away."
+    set tearoff [tkTearOffMenu .m1 40 40]
+    $tearoff postcascade 0
+    list [$tearoff postcascade 0] [destroy .m1] [destroy .m2]
+} {{} {} {}}
+test menuDraw-16.2 {TkPostSubMenu} {unixOnly} {
+    catch {destroy .m1}
+    catch {destroy .m2}
+    catch {destroy .m3}
+    menu .m1
+    .m1 add cascade -label "two" -menu .m2
+    .m1 add cascade -label "three" -menu .m3
+    menu .m2
+    .m2 add command -label "two"
+    menu .m3
+    .m3 add command -label "three"
+    set tearoff [tkTearOffMenu .m1 40 40]
+    $tearoff postcascade 0
+    list [$tearoff postcascade 1] [destroy .m1] [destroy .m2] [destroy .m3]
+} {{} {} {} {}}
+test menuDraw-16.3 {TkPostSubMenu} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add cascade -label test -menu .m2
+    list [.m1 postcascade 1] [destroy .m1]
+} {{} {}}
+test menuDraw-16.4 {TkPostSubMenu} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add cascade -label test
+    set tearoff [tkTearOffMenu .m1 40 40]
+    list [$tearoff postcascade 0] [destroy .m1]
+} {{} {}}
+test menuDraw-16.5 {TkPostSubMenu} {unixOnly} {
+    catch {destroy .m1}
+    catch {destroy .m2}
+    menu .m1
+    .m1 add cascade -label test -menu .m2
+    menu .m2 -postcommand "glorp"
+    set tearoff [tkTearOffMenu .m1 40 40]
+    list [catch {$tearoff postcascade test} msg] $msg [destroy .m1] [destroy .m2]
+} {1 {invalid command name "glorp"} {} {}}
+test menuDraw-16.6 {TkPostSubMenu} {menuInteractive} {
+    catch {destroy .m1}
+    catch {destroy .m2}
+    menu .m1
+    .m1 add cascade -label test -menu .m2
+    menu .m2
+    .m2 add command -label "Hit ESCAPE to get rid of this menu"
+    set tearoff [tkTearOffMenu .m1 40 40]
+    list [$tearoff postcascade 0] [destroy .m1] [destroy .m2]
+} {{} {} {}}
+
+test menuDraw-17.1 {AdjustMenuCoords - menubar} {unixOnly} {
+    catch {destroy .m1}
+    catch {destroy .m2}
+    menu .m1 -tearoff 0
+    .m1 add cascade -label test -menu .m2
+    menu .m2 -tearoff 0
+    .m2 add command -label foo
+    . configure -menu .m1
+    foreach w [winfo children .] {
+	if {[$w cget -type] == "menubar"} {
+		break
+	}
+    }
+    list [$w postcascade 0] [. configure -menu ""] [destroy .m1] [destroy .m2]
+} {{} {} {} {}}
+test menuDraw-17.2 {AdjustMenuCoords - menu} {menuInteractive} {
+    catch {destroy .m1}
+    catch {destroy .m2}
+    menu .m1
+    .m1 add cascade -label test -menu .m2
+    menu .m2
+    .m2 add command -label "Hit ESCAPE to make this menu go away"
+    set tearoff [tkTearOffMenu .m1 40 40]
+    list [$tearoff postcascade 0] [destroy .m1] [destroy .m2]
+} {{} {} {}}
+
+deleteWindows