← Back to branch summary

~ubuntu-branches/ubuntu/dapper/tk8.0/dapper-updates

« back to all changes in this revision

Viewing changes to tests/msgbox.test

  • Committer: Bazaar Package Importer
  • Author(s): Mike Markley
  • Date: 2001-07-24 21:57:40 UTC
  • Revision ID: james.westby@ubuntu.com-20010724215740-r70t25rtmbqjil2h
Tags: upstream-8.0.5
Import upstream version 8.0.5

Show diffs side-by-side

added added

removed removed

Lines of Context:
tests/msgbox.test
 
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
#
 
6
# See the file "license.terms" for information on usage and redistribution
 
7
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
8
#
 
9
# RCS: @(#) $Id: msgbox.test,v 1.2 1998/09/14 18:23:49 stanton Exp $
 
10
#
 
11
 
 
12
if {[string compare test [info procs test]] == 1} {
 
13
    source defs
 
14
}
 
15
 
 
16
test msgbox-1.1 {tk_messageBox command} {
 
17
    list [catch {tk_messageBox -foo} msg] $msg
 
18
} {1 {unknown option "-foo", must be -default, -icon, -message, -parent, -title or -type}}
 
19
test msgbox-1.2 {tk_messageBox command} {
 
20
    list [catch {tk_messageBox -foo bar} msg] $msg
 
21
} {1 {unknown option "-foo", must be -default, -icon, -message, -parent, -title or -type}}
 
22
 
 
23
catch {tk_messageBox -foo bar} msg
 
24
regsub -all ,      $msg "" options
 
25
regsub \"-foo\" $options "" options
 
26
 
 
27
foreach option $options {
 
28
    if {[string index $option 0] == "-"} {
 
29
        test msgbox-1.3 {tk_messageBox command} {
 
30
            list [catch {tk_messageBox $option} msg] $msg
 
31
        } [list 1 "value for \"$option\" missing"]
 
32
    }
 
33
}
 
34
 
 
35
test msgbox-1.4 {tk_messageBox command} {
 
36
    list [catch {tk_messageBox -default} msg] $msg
 
37
} {1 {value for "-default" missing}}
 
38
 
 
39
test msgbox-1.5 {tk_messageBox command} {
 
40
    list [catch {tk_messageBox -type foo} msg] $msg
 
41
} {1 {invalid message box type "foo", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel}}
 
42
 
 
43
test msgbox-1.6 {tk_messageBox command} {
 
44
    list [catch {tk_messageBox -default 1.1} msg] $msg
 
45
} {1 {invalid default button "1.1"}}
 
46
 
 
47
test msgbox-1.7 {tk_messageBox command} {
 
48
    list [catch {tk_messageBox -default foo} msg] $msg
 
49
} {1 {invalid default button "foo"}}
 
50
 
 
51
test msgbox-1.8 {tk_messageBox command} {
 
52
    list [catch {tk_messageBox -type yesno -default 3} msg] $msg
 
53
} {1 {invalid default button "3"}}
 
54
 
 
55
test msgbox-1.9 {tk_messageBox command} {
 
56
    list [catch {tk_messageBox -icon foo} msg] $msg
 
57
} {1 {invalid icon "foo", must be error, info, question or warning}}
 
58
 
 
59
test msgbox-1.10 {tk_messageBox command} {
 
60
    list [catch {tk_messageBox -parent foo.bar} msg] $msg
 
61
} {1 {bad window path name "foo.bar"}}
 
62
 
 
63
if {[info commands tkMessageBox] == ""} {
 
64
    set isNative 1
 
65
} else {
 
66
    set isNative 0
 
67
}
 
68
 
 
69
if {$isNative && ![info exists INTERACTIVE]} {
 
70
    puts " Some tests were skipped because they could not be performed"
 
71
    puts " automatically on this platform. If you wish to execute them"
 
72
    puts " interactively, set the TCL variable INTERACTIVE and re-run"
 
73
    puts " the test"
 
74
    return
 
75
}
 
76
 
 
77
proc ChooseMsg {parent btn} {
 
78
    global isNative
 
79
    if {!$isNative} {
 
80
        after 100 SendEventToMsg $parent $btn mouse
 
81
    }
 
82
}
 
83
 
 
84
proc ChooseMsgByKey {parent btn} {
 
85
    global isNative
 
86
    if {!$isNative} {
 
87
        after 100 SendEventToMsg $parent $btn key
 
88
    }
 
89
}
 
90
 
 
91
proc PressButton {btn} {
 
92
    event generate $btn <Enter>
 
93
    event generate $btn <ButtonPress-1> -x 5 -y 5
 
94
    event generate $btn <ButtonRelease-1> -x 5 -y 5
 
95
}
 
96
 
 
97
proc SendEventToMsg {parent btn type} {
 
98
    if {$parent != "."} {
 
99
        set w $parent.__tk__messagebox
 
100
    } else {
 
101
        set w .__tk__messagebox
 
102
    }
 
103
    if ![winfo ismapped $w.$btn] {
 
104
        update
 
105
    }
 
106
    if {$type == "mouse"} {
 
107
        PressButton $w.$btn
 
108
    } else {
 
109
        event generate $w <Enter>
 
110
        focus $w
 
111
        event generate $w.$btn <Enter>
 
112
        event generate $w <KeyPress> -keysym Return
 
113
    }
 
114
}
 
115
 
 
116
set parent .
 
117
 
 
118
set specs {
 
119
    {"abortretryignore"  MB_ABORTRETRYIGNORE  3  {"abort"  "retry"  "ignore"}} 
 
120
    {"ok"                MB_OK                1  {"ok"                      }} 
 
121
    {"okcancel"          MB_OKCANCEL          2  {"ok"     "cancel"         }} 
 
122
    {"retrycancel"       MB_RETRYCANCEL       2  {"retry"  "cancel"         }} 
 
123
    {"yesno"             MB_YESNO             2  {"yes"    "no"             }} 
 
124
    {"yesnocancel"       MB_YESNOCANCEL       3  {"yes"    "no"     "cancel"}}
 
125
}
 
126
 
 
127
#
 
128
# Try out all combinations of (type) x (default button) and
 
129
# (type) x (icon).
 
130
#
 
131
foreach spec $specs {
 
132
    set type [lindex $spec 0]
 
133
    set buttons [lindex $spec 3]
 
134
 
 
135
    set button [lindex $buttons 0]
 
136
    test msgbox-2.1 {tk_messageBox command} {
 
137
        ChooseMsg $parent $button
 
138
        tk_messageBox -title Hi -message "Please press $button" \
 
139
            -type $type
 
140
    } $button
 
141
 
 
142
    foreach icon {warning error info question} {
 
143
        test msgbox-2.2 {tk_messageBox command -icon option} {
 
144
            ChooseMsg $parent $button
 
145
            tk_messageBox -title Hi -message "Please press $button" \
 
146
                -type $type -icon $icon
 
147
        } $button
 
148
    }
 
149
 
 
150
    foreach button $buttons {
 
151
        test msgbox-2.3 {tk_messageBox command} {
 
152
            ChooseMsg $parent $button
 
153
            tk_messageBox -title Hi -message "Please press $button" \
 
154
                -type $type -default $button
 
155
        } "$button"
 
156
    }
 
157
}