1# This file is a Tcl script to test out Tk's "tk_messageBox" command.
2# It is organized in the standard fashion for Tcl tests.
3#
4# Copyright (c) 1996 Sun Microsystems, Inc.
5# Copyright (c) 1998-1999 by Scriptics Corporation.
6# All rights reserved.
7#
8# RCS: @(#) $Id$
9#
10
11package require tcltest 2.1
12eval tcltest::configure $argv
13tcltest::loadTestedCommands
14
15test msgbox-1.1 {tk_messageBox command} {
16    list [catch {tk_messageBox -foo} msg] $msg
17} {1 {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}}
18test msgbox-1.2 {tk_messageBox command} {
19    list [catch {tk_messageBox -foo bar} msg] $msg
20} {1 {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}}
21
22catch {tk_messageBox -foo bar} msg
23regsub -all ,      $msg "" options
24regsub \"-foo\" $options "" options
25
26foreach option $options {
27    if {[string index $option 0] eq "-"} {
28	test msgbox-1.3$option {tk_messageBox command} -body {
29	    tk_messageBox $option
30	} -returnCodes error -result "value for \"$option\" missing"
31    }
32}
33
34test msgbox-1.4 {tk_messageBox command} {
35    list [catch {tk_messageBox -default} msg] $msg
36} {1 {value for "-default" missing}}
37
38test msgbox-1.5 {tk_messageBox command} {
39    list [catch {tk_messageBox -type foo} msg] $msg
40} {1 {bad -type value "foo": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel}}
41
42proc createPlatformMsg {val} {
43    global tcl_platform
44    if {$tcl_platform(platform) == "unix"} {
45	return "invalid default button \"$val\""
46    }
47    return "bad -default value \"$val\": must be abort, retry, ignore, ok, cancel, no, or yes"
48}
49
50test msgbox-1.6 {tk_messageBox command} {
51    list [catch {tk_messageBox -default 1.1} msg] $msg
52} [list 1 [createPlatformMsg "1.1"]]
53
54test msgbox-1.7 {tk_messageBox command} {
55    list [catch {tk_messageBox -default foo} msg] $msg
56} [list 1 [createPlatformMsg "foo"]]
57
58test msgbox-1.8 {tk_messageBox command} {
59    list [catch {tk_messageBox -type yesno -default 3} msg] $msg
60} [list 1 [createPlatformMsg "3"]]
61
62test msgbox-1.9 {tk_messageBox command} {
63    list [catch {tk_messageBox -icon foo} msg] $msg
64} {1 {bad -icon value "foo": must be error, info, question, or warning}}
65
66test msgbox-1.10 {tk_messageBox command} {
67    list [catch {tk_messageBox -parent foo.bar} msg] $msg
68} {1 {bad window path name "foo.bar"}}
69
70set isNative [expr {[info commands tk::MessageBox] == ""}]
71
72proc ChooseMsg {parent btn} {
73    global isNative
74    if {!$isNative} {
75	after 100 SendEventToMsg $parent $btn mouse
76    }
77}
78
79proc ChooseMsgByKey {parent btn} {
80    global isNative
81    if {!$isNative} {
82	after 100 SendEventToMsg $parent $btn key
83    }
84}
85
86proc PressButton {btn} {
87    event generate $btn <Enter>
88    event generate $btn <ButtonPress-1> -x 5 -y 5
89    event generate $btn <ButtonRelease-1> -x 5 -y 5
90}
91
92proc SendEventToMsg {parent btn type} {
93    if {$parent != "."} {
94	set w $parent.__tk__messagebox
95    } else {
96	set w .__tk__messagebox
97    }
98    if ![winfo ismapped $w.$btn] {
99	update
100    }
101    if {$type == "mouse"} {
102	PressButton $w.$btn
103    } else {
104	event generate $w <Enter>
105	focus $w
106	event generate $w.$btn <Enter>
107	event generate $w <KeyPress> -keysym Return
108    }
109}
110
111set parent .
112
113set specs {
114    {"abortretryignore"  MB_ABORTRETRYIGNORE  3  {"abort"  "retry"  "ignore"}} 
115    {"ok"  		 MB_OK  	      1  {"ok"                      }} 
116    {"okcancel" 	 MB_OKCANCEL 	      2  {"ok"     "cancel"         }} 
117    {"retrycancel" 	 MB_RETRYCANCEL       2  {"retry"  "cancel"         }} 
118    {"yesno" 		 MB_YESNO 	      2  {"yes"    "no"             }} 
119    {"yesnocancel" 	 MB_YESNOCANCEL       3  {"yes"    "no"     "cancel"}}
120}
121
122#
123# Try out all combinations of (type) x (default button) and
124# (type) x (icon).
125#
126set count 1
127foreach spec $specs {
128    set type [lindex $spec 0]
129    set buttons [lindex $spec 3]
130
131    set button [lindex $buttons 0]
132    test msgbox-2.$count {tk_messageBox command} nonUnixUserInteraction {
133	ChooseMsg $parent $button
134	tk_messageBox -title Hi -message "Please press $button" \
135		-type $type
136    } $button
137    incr count
138
139    foreach icon {warning error info question} {
140	test msgbox-2.$count {tk_messageBox command -icon option} \
141		nonUnixUserInteraction {
142	    ChooseMsg $parent $button
143	    tk_messageBox -title Hi -message "Please press $button" \
144		    -type $type -icon $icon
145	} $button
146        incr count
147    }
148
149    foreach button $buttons {
150	test msgbox-2.$count {tk_messageBox command} nonUnixUserInteraction {
151	    ChooseMsg $parent $button
152	    tk_messageBox -title Hi -message "Please press $button" \
153		    -type $type -default $button
154	} "$button"
155        incr count
156    }
157}
158
159# These tests will hang your test suite if they fail.
160test msgbox-3.1 {tk_messageBox handles withdrawn parent} nonUnixUserInteraction {
161    wm withdraw .
162    ChooseMsg . "ok"
163    tk_messageBox -title Hi -message "Please press ok" \
164	    -type ok -default ok
165} "ok"
166wm deiconify .
167
168test msgbox-3.2 {tk_messageBox handles iconified parent} nonUnixUserInteraction {
169    wm iconify .
170    ChooseMsg . "ok"
171    tk_messageBox -title Hi -message "Please press ok" \
172	    -type ok -default ok
173} "ok"
174wm deiconify .
175
176# cleanup
177cleanupTests
178return
179