3 # Implements messageboxes for platforms that do not have native
6 # RCS: @(#) $Id: msgbox.tcl,v 1.24.2.3 2006/01/25 18:21:41 dgp Exp $
8 # Copyright (c) 1994-1997 Sun Microsystems, Inc.
10 # See the file "license.terms" for information on usage and redistribution
11 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14 # Ensure existence of ::tk::dialog namespace
16 namespace eval ::tk::dialog {}
18 image create
bitmap ::tk::dialog::b1 -foreground black
\
19 -data
"#define b1_width 32\n#define b1_height 32
20 static unsigned char q1_bits[] = {
21 0x00, 0xf8, 0x1f, 0x00, 0x00, 0x07, 0xe0, 0x00, 0xc0, 0x00, 0x00, 0x03,
22 0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10,
23 0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,
24 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
25 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
26 0x01, 0x00, 0x00, 0x80, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,
27 0x04, 0x00, 0x00, 0x20, 0x08, 0x00, 0x00, 0x10, 0x10, 0x00, 0x00, 0x08,
28 0x60, 0x00, 0x00, 0x04, 0x80, 0x03, 0x80, 0x03, 0x00, 0x0c, 0x78, 0x00,
29 0x00, 0x30, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00,
30 0x00, 0x80, 0x04, 0x00, 0x00, 0x00, 0x05, 0x00, 0x00, 0x00, 0x06, 0x00,
31 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
32 image create
bitmap ::tk::dialog::b2 -foreground white
\
33 -data
"#define b2_width 32\n#define b2_height 32
34 static unsigned char b2_bits[] = {
35 0x00, 0x00, 0x00, 0x00, 0x00, 0xf8, 0x1f, 0x00, 0x00, 0xff, 0xff, 0x00,
36 0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f,
37 0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,
38 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
39 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
40 0xfe, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,
41 0xf8, 0xff, 0xff, 0x1f, 0xf0, 0xff, 0xff, 0x0f, 0xe0, 0xff, 0xff, 0x07,
42 0x80, 0xff, 0xff, 0x03, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0xf0, 0x07, 0x00,
43 0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00,
44 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
45 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
46 image create
bitmap ::tk::dialog::q -foreground blue
\
47 -data
"#define q_width 32\n#define q_height 32
48 static unsigned char q_bits[] = {
49 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
50 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x07, 0x00,
51 0x00, 0x10, 0x0f, 0x00, 0x00, 0x18, 0x1e, 0x00, 0x00, 0x38, 0x1e, 0x00,
52 0x00, 0x38, 0x1e, 0x00, 0x00, 0x10, 0x0f, 0x00, 0x00, 0x80, 0x07, 0x00,
53 0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00,
54 0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00,
55 0x00, 0xe0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
56 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
57 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
58 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
59 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
60 image create
bitmap ::tk::dialog::i -foreground blue
\
61 -data
"#define i_width 32\n#define i_height 32
62 static unsigned char i_bits[] = {
63 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
64 0x00, 0xe0, 0x01, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00,
65 0x00, 0xe0, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
66 0x00, 0xf8, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,
67 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,
68 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xf0, 0x07, 0x00,
69 0x00, 0xf8, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
70 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
71 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
72 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
73 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
74 image create
bitmap ::tk::dialog::w1 -foreground black
\
75 -data
"#define w1_width 32\n#define w1_height 32
76 static unsigned char w1_bits[] = {
77 0x00, 0x80, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20, 0x04, 0x00,
78 0x00, 0x10, 0x04, 0x00, 0x00, 0x10, 0x08, 0x00, 0x00, 0x08, 0x08, 0x00,
79 0x00, 0x08, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x20, 0x00,
80 0x00, 0x02, 0x20, 0x00, 0x00, 0x02, 0x40, 0x00, 0x00, 0x01, 0x40, 0x00,
81 0x00, 0x01, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x00, 0x01,
82 0x40, 0x00, 0x00, 0x01, 0x40, 0x00, 0x00, 0x02, 0x20, 0x00, 0x00, 0x02,
83 0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08,
84 0x08, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10, 0x04, 0x00, 0x00, 0x10,
85 0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x20, 0x01, 0x00, 0x00, 0x40,
86 0x01, 0x00, 0x00, 0x40, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20,
87 0xfc, 0xff, 0xff, 0x1f, 0x00, 0x00, 0x00, 0x00};"
88 image create
bitmap ::tk::dialog::w2 -foreground yellow
\
89 -data
"#define w2_width 32\n#define w2_height 32
90 static unsigned char w2_bits[] = {
91 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,
92 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xf0, 0x07, 0x00,
93 0x00, 0xf0, 0x0f, 0x00, 0x00, 0xf8, 0x0f, 0x00, 0x00, 0xf8, 0x1f, 0x00,
94 0x00, 0xfc, 0x1f, 0x00, 0x00, 0xfc, 0x3f, 0x00, 0x00, 0xfe, 0x3f, 0x00,
95 0x00, 0xfe, 0x7f, 0x00, 0x00, 0xff, 0x7f, 0x00, 0x00, 0xff, 0xff, 0x00,
96 0x80, 0xff, 0xff, 0x00, 0x80, 0xff, 0xff, 0x01, 0xc0, 0xff, 0xff, 0x01,
97 0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07,
98 0xf0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f, 0xf8, 0xff, 0xff, 0x0f,
99 0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x1f, 0xfe, 0xff, 0xff, 0x3f,
100 0xfe, 0xff, 0xff, 0x3f, 0xfe, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x1f,
101 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
102 image create
bitmap ::tk::dialog::w3 -foreground black
\
103 -data
"#define w3_width 32\n#define w3_height 32
104 static unsigned char w3_bits[] = {
105 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
106 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
107 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
108 0x00, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,
109 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,
110 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00,
111 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00,
112 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,
113 0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00,
114 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
115 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
117 # ::tk::MessageBox --
119 # Pops up a messagebox with an application-supplied message with
120 # an icon and a list of buttons. This procedure will be called
121 # by tk_messageBox if the platform does not have native
122 # messagebox support, or if the particular type of messagebox is
123 # not supported natively.
125 # Color icons are used on Unix displays that have a color
126 # depth of 4 or more and $tk_strictMotif is not on.
128 # This procedure is a private procedure shouldn't be called
129 # directly. Call tk_messageBox instead.
131 # See the user documentation for details on what tk_messageBox does.
133 proc ::tk::MessageBox {args
} {
134 global tcl_platform tk_strictMotif
137 set w
::tk::PrivMsgBox
141 # The default value of the title is space (" ") not the empty string
142 # because for some window managers, a
144 # causes the window title to be "foo" instead of the empty string.
155 tclParseConfigSpec
$w $specs "" $args
157 if {[lsearch -exact {info warning
error question
} $data(-icon)] == -1} {
158 error "bad -icon value \"$data(-icon)\": must be error, info, question, or warning"
161 # Store tk windowingsystem to avoid too many calls
162 set windowingsystem
[tk windowingsystem
]
163 if {$windowingsystem eq
"classic" ||
$windowingsystem eq
"aqua"} {
164 switch -- $data(-icon) {
165 "error" {set data
(-icon) "stop"}
166 "warning" {set data
(-icon) "caution"}
167 "info" {set data
(-icon) "note"}
171 if {![winfo exists
$data(-parent)]} {
172 error "bad window path name \"$data(-parent)\""
175 switch -- $data(-type) {
177 set names
[list abort retry ignore
]
178 set labels
[list &Abort
&Retry
&Ignore
]
185 set names
[list ok cancel
]
186 set labels
[list &OK
&Cancel
]
189 set names
[list retry cancel
]
190 set labels
[list &Retry
&Cancel
]
193 set names
[list yes no
]
194 set labels
[list &Yes
&No
]
197 set names
[list yes no cancel
]
198 set labels
[list &Yes
&No
&Cancel
]
201 error "bad -type value \"$data(-type)\": must be\
202 abortretryignore, ok, okcancel, retrycancel,\
203 yesno, or yesnocancel"
208 foreach name
$names lab
$labels {
209 lappend buttons
[list $name -text [mc
$lab]]
212 # If no default button was specified, the default default is the
213 # first button (Bug: 2218).
215 if {$data(-default) eq
""} {
216 set data
(-default) [lindex [lindex $buttons 0] 0]
220 foreach btn
$buttons {
221 if {[lindex $btn 0] eq
$data(-default)} {
227 error "invalid default button \"$data(-default)\""
230 # 2. Set the dialog to be a child window of $parent
233 if {$data(-parent) ne
"."} {
234 set w
$data(-parent).__tk__messagebox
236 set w .__tk__messagebox
239 # 3. Create the top-level window and divide it into top
243 toplevel $w -class Dialog
244 wm title
$w $data(-title)
245 wm iconname
$w Dialog
246 wm protocol
$w WM_DELETE_WINDOW
{ }
247 # There is only one background colour for the whole dialog
248 set bg
[$w cget
-background]
250 # Message boxes should be transient with respect to their parent so that
251 # they always stay on top of the parent window. But some window managers
252 # will simply create the child window as withdrawn if the parent is not
253 # viewable (because it is withdrawn or iconified). This is not good for
254 # "grab"bed windows. So only make the message box transient if the parent
257 if {[winfo viewable
[winfo toplevel $data(-parent)]] } {
258 wm transient
$w $data(-parent)
261 if {$windowingsystem eq
"classic" ||
$windowingsystem eq
"aqua"} {
262 unsupported
::MacWindowStyle style
$w dBoxProc
265 frame $w.bot
-background $bg
266 pack $w.bot
-side bottom
-fill both
267 frame $w.top
-background $bg
268 pack $w.top
-side top
-fill both
-expand 1
269 if {$windowingsystem ne
"classic" && $windowingsystem ne
"aqua"} {
270 $w.bot configure
-relief raised
-bd 1
271 $w.top configure
-relief raised
-bd 1
274 # 4. Fill the top part with bitmap and message (use the option
275 # database for -wraplength and -font so that they can be
276 # overridden by the caller).
278 option add
*Dialog.msg.wrapLength
3i widgetDefault
279 if {$windowingsystem eq
"classic" ||
$windowingsystem eq
"aqua"} {
280 option add
*Dialog.msg.
font system widgetDefault
282 option add
*Dialog.msg.
font {Times
14} widgetDefault
285 label $w.msg
-anchor nw
-justify left
-text $data(-message) \
287 if {$data(-icon) ne
""} {
288 if {($windowingsystem eq
"classic" ||
$windowingsystem eq
"aqua")
289 ||
([winfo depth
$w] < 4) ||
$tk_strictMotif} {
290 label $w.
bitmap -bitmap $data(-icon) -background $bg
292 canvas $w.
bitmap -width 32 -height 32 -highlightthickness 0 \
294 switch $data(-icon) {
296 $w.
bitmap create oval
0 0 31 31 -fill red
-outline black
297 $w.
bitmap create line
9 9 23 23 -fill white
-width 4
298 $w.
bitmap create line
9 23 23 9 -fill white
-width 4
301 $w.
bitmap create
image 0 0 -anchor nw
\
302 -image ::tk::dialog::b1
303 $w.
bitmap create
image 0 0 -anchor nw
\
304 -image ::tk::dialog::b2
305 $w.
bitmap create
image 0 0 -anchor nw
\
306 -image ::tk::dialog::i
309 $w.
bitmap create
image 0 0 -anchor nw
\
310 -image ::tk::dialog::b1
311 $w.
bitmap create
image 0 0 -anchor nw
\
312 -image ::tk::dialog::b2
313 $w.
bitmap create
image 0 0 -anchor nw
\
314 -image ::tk::dialog::q
317 $w.
bitmap create
image 0 0 -anchor nw
\
318 -image ::tk::dialog::w1
319 $w.
bitmap create
image 0 0 -anchor nw
\
320 -image ::tk::dialog::w2
321 $w.
bitmap create
image 0 0 -anchor nw
\
322 -image ::tk::dialog::w3
327 grid $w.
bitmap $w.msg
-in $w.top
-sticky news
-padx 2m
-pady 2m
328 grid columnconfigure
$w.top
1 -weight 1
329 grid rowconfigure
$w.top
0 -weight 1
331 # 5. Create a row of buttons at the bottom of the dialog.
334 foreach but
$buttons {
335 set name
[lindex $but 0]
336 set opts
[lrange $but 1 end
]
337 if {![llength $opts]} {
338 # Capitalize the first letter of $name
339 set capName
[string toupper
$name 0]
340 set opts
[list -text $capName]
343 eval [list tk::AmpWidget button $w.
$name -padx 3m
] $opts \
344 [list -command [list set tk::Priv(button) $name]]
346 if {$name eq
$data(-default)} {
347 $w.
$name configure
-default active
349 $w.
$name configure
-default normal
351 grid $w.
$name -in $w.bot
-row 0 -column $i -padx 3m
-pady 2m
-sticky ew
352 grid columnconfigure
$w.bot
$i -uniform buttons
355 # create the binding for the key accelerator, based on the underline
357 # set underIdx [$w.$name cget -under]
358 # if {$underIdx >= 0} {
359 # set key [string index [$w.$name cget -text] $underIdx]
360 # bind $w <Alt-[string tolower $key]> [list $w.$name invoke]
361 # bind $w <Alt-[string toupper $key]> [list $w.$name invoke]
364 bind $w <Alt-Key
> [list ::tk::AltKeyInDialog $w %A
]
366 if {$data(-default) ne
""} {
368 if {"Button" eq
[winfo class
%W
]} {
369 %W configure
-default active
373 if {"Button" eq
[winfo class
%W
]} {
374 %W configure
-default normal
379 # 6. Create a binding for <Return> on the dialog
382 if {"Button" eq
[winfo class
%W
]} {
387 # 7. Withdraw the window, then update all the geometry information
388 # so we know how big it wants to be, then center the window in the
389 # display and de-iconify it.
391 ::tk::PlaceWindow $w widget
$data(-parent)
393 # 8. Set a grab and claim the focus too.
395 if {$data(-default) ne
""} {
396 set focus $w.
$data(-default)
400 ::tk::SetFocusGrab $w $focus
402 # 9. Wait for the user to respond, then restore the focus and
403 # return the index of the selected button. Restore the focus
404 # before deleting the window, since otherwise the window manager
405 # may take the focus away so we can't redirect it. Finally,
406 # restore any grab that was in effect.
408 vwait ::tk::Priv(button)
410 ::tk::RestoreFocusGrab $w $focus