1
# This file is a Tcl script to test menus in Tk. It is
2
# organized in the standard fashion for Tcl tests. It tests
3
# the common implementation of Macintosh and Windows menus.
5
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
7
# See the file "license.terms" for information on usage and redistribution
8
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
10
# RCS: @(#) $Id: macWinMenu.test,v 1.2 1998/09/14 18:23:48 stanton Exp $
12
if {$tcl_platform(platform) == "unix"} {
16
if {[lsearch [image types] test] < 0} {
17
puts "This application hasn't been compiled with the \"test\" image"
18
puts "type, so I can't run this test. Are you sure you're using"
19
puts "tktest instead of wish?"
23
if {[info procs test] != "test"} {
27
proc deleteWindows {} {
28
foreach i [winfo children .] {
37
if {$tcl_platform(platform) == "windows" && ![info exists INTERACTIVE]} {
38
puts " Some tests were skipped because they could not be performed"
39
puts " automatically on this platform. If you wish to execute them"
40
puts " interactively, set the TCL variable INTERACTIVE and re-run"
44
test macWinMenu-1.1 {PreprocessMenu} {
46
menu .m1 -postcommand "destroy .m1"
47
.m1 add command -label "macWinMenu-1.1: Hit Escape"
48
list [catch {.m1 post 40 40} msg] $msg
50
if {$tcl_platform(platform) != "windows" || [info exists INTERACTIVE]} {
51
test macWinMenu-1.2 {PreprocessMenu} {
56
menu .m1 -postcommand "set foo1 .m1"
57
.m1 add cascade -menu .m2 -label "macWinMenu-1.2: Hit Escape"
58
menu .m2 -postcommand "set foo2 .m2"
60
list [catch {.m1 post 40 40} msg] $msg [set foo1] [set foo2] [destroy .m1 .m2] [catch {unset foo1}] [catch {unset foo2}]
61
} {0 .m2 .m1 .m2 {} 0 0}
63
test macWinMenu-1.3 {PreprocessMenu} {
68
label .l1 -text "Preparing menus..."
71
menu .m1 -postcommand ".l1 configure -text \"Destroying .m1...\"; update idletasks; destroy .m1"
72
menu .m2 -postcommand ".l1 configure -text \"Destroying .m2...\"; update idletasks; destroy .m2"
73
menu .m3 -postcommand ".l1 configure -text \"Destroying .m3...\"; update idletasks; destroy .m3"
74
.m1 add cascade -menu .m2 -label "macWinMenu-1.3: Hit Escape (.m2)"
75
.m1 add cascade -menu .m3 -label ".m3"
77
list [catch {.m1 post 40 40} msg] $msg [destroy .l1 .m2 .m3]
79
test macWinMenu-1.4 {PreprocessMenu} {
85
label .l1 -text "Preparing menus..."
88
menu .m1 -postcommand ".l1 configure -text \"Destroying .m1...\"; update idletasks; destroy .m1"
89
.m1 add cascade -menu .m2 -label "macWinMenu-1.4: Hit Escape (.m2)"
90
.m1 add cascade -menu .m3 -label ".m3"
91
menu .m2 -postcommand ".l1 configure -text \"Destroying .m2...\"; update idletasks; destroy .m2"
92
.m2 add cascade -menu .m4 -label ".m4"
93
menu .m3 -postcommand ".l1 configure -text \"Destroying .m3...\"; update idletasks; destroy .m3"
94
menu .m4 -postcommand ".l1 configure -text \"Destroying .m4...\"; update idletasks; destroy .m4"
96
list [catch {.m1 post 40 40} msg] $msg [destroy .l1 .m2 .m3 .m4]
98
test macWinMenu-1.5 {PreprocessMenu} {
102
.m1 add cascade -menu .m2 -label "You may need to hit Escape to get this menu to go away."
103
menu .m2 -postcommand glorp
104
list [catch {.m1 post 40 40} msg] $msg [destroy .m1 .m2]
105
} {1 {invalid command name "glorp"} {}}
107
if {$tcl_platform(platform) != "windows" || [info exists INTERACTIVE]} {
108
test macWinMenu-2.1 {TkPreprocessMenu} {
111
menu .m1 -postcommand "set foo 2.1"
112
.m1 add command -label "macWinMenu-2.1: Hit Escape"
113
list [catch {.m1 post 40 40} msg] $msg [set foo] [destroy .m1] [unset foo]