# Implements messageboxes for platforms that do not have native
# RCS: @(#) $Id: msgbox.tcl,v 1.24.2.2 2004/05/13 23:28:34 dkf Exp $
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Ensure existence of ::tk::dialog namespace
namespace eval ::tk::dialog {}
image create
bitmap ::tk::dialog::b1 -foreground black
\
-data
"#define b1_width 32\n#define b1_height 32
static unsigned char q1_bits[] = {
0x00, 0xf8, 0x1f, 0x00, 0x00, 0x07, 0xe0, 0x00, 0xc0, 0x00, 0x00, 0x03,
0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10,
0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,
0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
0x01, 0x00, 0x00, 0x80, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,
0x04, 0x00, 0x00, 0x20, 0x08, 0x00, 0x00, 0x10, 0x10, 0x00, 0x00, 0x08,
0x60, 0x00, 0x00, 0x04, 0x80, 0x03, 0x80, 0x03, 0x00, 0x0c, 0x78, 0x00,
0x00, 0x30, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00,
0x00, 0x80, 0x04, 0x00, 0x00, 0x00, 0x05, 0x00, 0x00, 0x00, 0x06, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
image create
bitmap ::tk::dialog::b2 -foreground white
\
-data
"#define b2_width 32\n#define b2_height 32
static unsigned char b2_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x00, 0xf8, 0x1f, 0x00, 0x00, 0xff, 0xff, 0x00,
0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f,
0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,
0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
0xfe, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,
0xf8, 0xff, 0xff, 0x1f, 0xf0, 0xff, 0xff, 0x0f, 0xe0, 0xff, 0xff, 0x07,
0x80, 0xff, 0xff, 0x03, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0xf0, 0x07, 0x00,
0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00,
0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
image create
bitmap ::tk::dialog::q -foreground blue
\
-data
"#define q_width 32\n#define q_height 32
static unsigned char q_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x07, 0x00,
0x00, 0x10, 0x0f, 0x00, 0x00, 0x18, 0x1e, 0x00, 0x00, 0x38, 0x1e, 0x00,
0x00, 0x38, 0x1e, 0x00, 0x00, 0x10, 0x0f, 0x00, 0x00, 0x80, 0x07, 0x00,
0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00,
0x00, 0xe0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
image create
bitmap ::tk::dialog::i -foreground blue
\
-data
"#define i_width 32\n#define i_height 32
static unsigned char i_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0xe0, 0x01, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00,
0x00, 0xe0, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0xf8, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,
0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,
0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xf0, 0x07, 0x00,
0x00, 0xf8, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
image create
bitmap ::tk::dialog::w1 -foreground black
\
-data
"#define w1_width 32\n#define w1_height 32
static unsigned char w1_bits[] = {
0x00, 0x80, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20, 0x04, 0x00,
0x00, 0x10, 0x04, 0x00, 0x00, 0x10, 0x08, 0x00, 0x00, 0x08, 0x08, 0x00,
0x00, 0x08, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x20, 0x00,
0x00, 0x02, 0x20, 0x00, 0x00, 0x02, 0x40, 0x00, 0x00, 0x01, 0x40, 0x00,
0x00, 0x01, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x00, 0x01,
0x40, 0x00, 0x00, 0x01, 0x40, 0x00, 0x00, 0x02, 0x20, 0x00, 0x00, 0x02,
0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08,
0x08, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10, 0x04, 0x00, 0x00, 0x10,
0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x20, 0x01, 0x00, 0x00, 0x40,
0x01, 0x00, 0x00, 0x40, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20,
0xfc, 0xff, 0xff, 0x1f, 0x00, 0x00, 0x00, 0x00};"
image create
bitmap ::tk::dialog::w2 -foreground yellow
\
-data
"#define w2_width 32\n#define w2_height 32
static unsigned char w2_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,
0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xf0, 0x07, 0x00,
0x00, 0xf0, 0x0f, 0x00, 0x00, 0xf8, 0x0f, 0x00, 0x00, 0xf8, 0x1f, 0x00,
0x00, 0xfc, 0x1f, 0x00, 0x00, 0xfc, 0x3f, 0x00, 0x00, 0xfe, 0x3f, 0x00,
0x00, 0xfe, 0x7f, 0x00, 0x00, 0xff, 0x7f, 0x00, 0x00, 0xff, 0xff, 0x00,
0x80, 0xff, 0xff, 0x00, 0x80, 0xff, 0xff, 0x01, 0xc0, 0xff, 0xff, 0x01,
0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07,
0xf0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f, 0xf8, 0xff, 0xff, 0x0f,
0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x1f, 0xfe, 0xff, 0xff, 0x3f,
0xfe, 0xff, 0xff, 0x3f, 0xfe, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x1f,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
image create
bitmap ::tk::dialog::w3 -foreground black
\
-data
"#define w3_width 32\n#define w3_height 32
static unsigned char w3_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,
0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,
0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00,
0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,
0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
# Pops up a messagebox with an application-supplied message with
# an icon and a list of buttons. This procedure will be called
# by tk_messageBox if the platform does not have native
# messagebox support, or if the particular type of messagebox is
# not supported natively.
# Color icons are used on Unix displays that have a color
# depth of 4 or more and $tk_strictMotif is not on.
# This procedure is a private procedure shouldn't be called
# directly. Call tk_messageBox instead.
# See the user documentation for details on what tk_messageBox does.
proc ::tk::MessageBox {args
} {
global tcl_platform tk_strictMotif
# The default value of the title is space (" ") not the empty string
# because for some window managers, a
# causes the window title to be "foo" instead of the empty string.
tclParseConfigSpec
$w $specs "" $args
if {[lsearch -exact {info warning
error question
} $data(-icon)] == -1} {
error "bad -icon value \"$data(-icon)\": must be error, info, question, or warning"
if {[string equal
[tk windowingsystem
] "classic"]
||
[string equal
[tk windowingsystem
] "aqua"]} {
"error" {set data
(-icon) "stop"}
"warning" {set data
(-icon) "caution"}
"info" {set data
(-icon) "note"}
if {![winfo exists
$data(-parent)]} {
error "bad window path name \"$data(-parent)\""
set names
[list abort retry ignore
]
set labels
[list &Abort
&Retry
&Ignore
]
set names
[list ok cancel
]
set labels
[list &OK
&Cancel
]
set names
[list retry cancel
]
set labels
[list &Retry
&Cancel
]
set labels
[list &Yes
&No
]
set names
[list yes no cancel
]
set labels
[list &Yes
&No
&Cancel
]
error "bad -type value \"$data(-type)\": must be\
abortretryignore, ok, okcancel, retrycancel,\
foreach name
$names lab
$labels {
lappend buttons
[list $name -text [mc
$lab]]
# If no default button was specified, the default default is the
# first button (Bug: 2218).
if {$data(-default) == ""} {
set data
(-default) [lindex [lindex $buttons 0] 0]
if {[string equal
[lindex $btn 0] $data(-default)]} {
error "invalid default button \"$data(-default)\""
# 2. Set the dialog to be a child window of $parent
if {[string compare
$data(-parent) .
]} {
set w
$data(-parent).__tk__messagebox
# 3. Create the top-level window and divide it into top
toplevel $w -class Dialog
wm title
$w $data(-title)
wm protocol
$w WM_DELETE_WINDOW
{ }
# There is only one background colour for the whole dialog
set bg
[$w cget
-background]
# Message boxes should be transient with respect to their parent so that
# they always stay on top of the parent window. But some window managers
# will simply create the child window as withdrawn if the parent is not
# viewable (because it is withdrawn or iconified). This is not good for
# "grab"bed windows. So only make the message box transient if the parent
if {[winfo viewable
[winfo toplevel $data(-parent)]] } {
wm transient
$w $data(-parent)
if {[string equal
[tk windowingsystem
] "classic"]
||
[string equal
[tk windowingsystem
] "aqua"]} {
unsupported
::MacWindowStyle style
$w dBoxProc
frame $w.bot
-background $bg
pack $w.bot
-side bottom
-fill both
frame $w.top
-background $bg
pack $w.top
-side top
-fill both
-expand 1
if {![string equal
[tk windowingsystem
] "classic"]
&& ![string equal
[tk windowingsystem
] "aqua"]} {
$w.bot configure
-relief raised
-bd 1
$w.top configure
-relief raised
-bd 1
# 4. Fill the top part with bitmap and message (use the option
# database for -wraplength and -font so that they can be
# overridden by the caller).
option add
*Dialog.msg.wrapLength
3i widgetDefault
if {[string equal
[tk windowingsystem
] "classic"]
||
[string equal
[tk windowingsystem
] "aqua"]} {
option add
*Dialog.msg.
font system widgetDefault
option add
*Dialog.msg.
font {Times
14} widgetDefault
label $w.msg
-anchor nw
-justify left
-text $data(-message) \
if {[string compare
$data(-icon) ""]} {
if {([string equal
[tk windowingsystem
] "classic"]
||
[string equal
[tk windowingsystem
] "aqua"])
||
([winfo depth
$w] < 4) ||
$tk_strictMotif} {
label $w.
bitmap -bitmap $data(-icon) -background $bg
canvas $w.
bitmap -width 32 -height 32 -highlightthickness 0 \
$w.
bitmap create oval
0 0 31 31 -fill red
-outline black
$w.
bitmap create line
9 9 23 23 -fill white
-width 4
$w.
bitmap create line
9 23 23 9 -fill white
-width 4
$w.
bitmap create
image 0 0 -anchor nw
\
$w.
bitmap create
image 0 0 -anchor nw
\
$w.
bitmap create
image 0 0 -anchor nw
\
$w.
bitmap create
image 0 0 -anchor nw
\
$w.
bitmap create
image 0 0 -anchor nw
\
$w.
bitmap create
image 0 0 -anchor nw
\
$w.
bitmap create
image 0 0 -anchor nw
\
$w.
bitmap create
image 0 0 -anchor nw
\
$w.
bitmap create
image 0 0 -anchor nw
\
grid $w.
bitmap $w.msg
-in $w.top
-sticky news
-padx 2m
-pady 2m
grid columnconfigure
$w.top
1 -weight 1
grid rowconfigure
$w.top
0 -weight 1
# 5. Create a row of buttons at the bottom of the dialog.
set opts
[lrange $but 1 end
]
# Capitalize the first letter of $name
set capName
[string toupper
$name 0]
set opts
[list -text $capName]
eval [list tk::AmpWidget button $w.
$name -padx 3m
] $opts \
[list -command [list set tk::Priv(button) $name]]
if {[string equal
$name $data(-default)]} {
$w.
$name configure
-default active
$w.
$name configure
-default normal
grid $w.
$name -in $w.bot
-row 0 -column $i -padx 3m
-pady 2m
-sticky ew
grid columnconfigure
$w.bot
$i -uniform buttons
# create the binding for the key accelerator, based on the underline
# set underIdx [$w.$name cget -under]
# set key [string index [$w.$name cget -text] $underIdx]
# bind $w <Alt-[string tolower $key]> [list $w.$name invoke]
# bind $w <Alt-[string toupper $key]> [list $w.$name invoke]
bind $w <Alt-Key
> [list ::tk::AltKeyInDialog $w %A
]
if {[string compare
{} $data(-default)]} {
if {[string equal Button
[winfo class
%W
]]} {
%W configure
-default active
if {[string equal Button
[winfo class
%W
]]} {
%W configure
-default normal
# 6. Create a binding for <Return> on the dialog
if {[string equal Button
[winfo class
%W
]]} {
# 7. Withdraw the window, then update all the geometry information
# so we know how big it wants to be, then center the window in the
# display and de-iconify it.
::tk::PlaceWindow $w widget
$data(-parent)
# 8. Set a grab and claim the focus too.
if {[string compare
$data(-default) ""]} {
set focus $w.
$data(-default)
::tk::SetFocusGrab $w $focus
# 9. Wait for the user to respond, then restore the focus and
# return the index of the selected button. Restore the focus
# before deleting the window, since otherwise the window manager
# may take the focus away so we can't redirect it. Finally,
# restore any grab that was in effect.
::tk::RestoreFocusGrab $w $focus