OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tk/] [tests/] [msgbox.test] - Blame information for rev 1765

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom 
# 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.1.1.1 2002-01-16 10:25:59 markom 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, -modal, -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, -modal, -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
93 
    event generate $btn  -x 5 -y 5
94 
    event generate $btn  -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
110 
        focus $w
111 
        event generate $w.$btn
112 
        event generate $w  -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 
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.