msgbox.tcl revision 3f54fd611f536639ec30dd53c48e5ec1897cc7d9
# msgbox.tcl --
#
# Implements messageboxes for platforms that do not have native
# messagebox support.
#
# SCCS: @(#) msgbox.tcl 1.4 96/09/05 11:30:30
#
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# tkMessageBox --
#
# 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.
#
# 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 tkMessageBox {args} {
global tkPriv
set w tkPrivMsgBox
upvar #0 $w data
#
# The default value of the title is space (" ") not the empty string
# because for some window managers, a
# wm title .foo ""
# causes the window title to be "foo" instead of the empty string.
#
set specs {
{-default "" "" ""}
{-icon "" "" "info"}
{-message "" "" ""}
{-parent "" "" .}
{-title "" "" " "}
{-type "" "" "ok"}
}
tclParseConfigSpec $w $specs "" $args
if {[lsearch {info warning error question} $data(-icon)] == -1} {
error "invalid icon \"$data(-icon)\", must be error, info, question or warning"
}
if ![winfo exists $data(-parent)] {
error "bad window path name \"$data(-parent)\""
}
case $data(-type) {
abortretryignore {
set buttons {
{abort -width 6 -text Abort -under 0}
{retry -width 6 -text Retry -under 0}
{ignore -width 6 -text Ignore -under 0}
}
}
ok {
set buttons {
{ok -width 6 -text OK -under 0}
}
if {$data(-default) == ""} {
set data(-default) "ok"
}
}
okcancel {
set buttons {
{ok -width 6 -text OK -under 0}
{cancel -width 6 -text Cancel -under 0}
}
}
retrycancel {
set buttons {
{retry -width 6 -text Retry -under 0}
{cancel -width 6 -text Cancel -under 0}
}
}
yesno {
set buttons {
{yes -width 6 -text Yes -under 0}
{no -width 6 -text No -under 0}
}
}
yesnocancel {
set buttons {
{yes -width 6 -text Yes -under 0}
{no -width 6 -text No -under 0}
{cancel -width 6 -text Cancel -under 0}
}
}
default {
error "invalid message box type \"$data(-type)\", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel"
}
}
if [string compare $data(-default) ""] {
set valid 0
foreach btn $buttons {
if ![string compare [lindex $btn 0] $data(-default)] {
set valid 1
break
}
}
if !$valid {
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
} else {
set w .__tk__messagebox
}
# 3. Create the top-level window and divide it into top
# and bottom parts.
catch {destroy $w}
toplevel $w -class Dialog
wm title $w $data(-title)
wm iconname $w Dialog
wm protocol $w WM_DELETE_WINDOW { }
wm transient $w $data(-parent)
frame $w.bot -relief raised -bd 1
pack $w.bot -side bottom -fill both
frame $w.top -relief raised -bd 1
pack $w.top -side top -fill both -expand 1
# 4. Fill the top part with bitmap and message (use the option
# database for -wraplength so that it can be overridden by
# the caller).
option add *Dialog.msg.wrapLength 3i widgetDefault
label $w.msg -justify left -text $data(-message)
catch {$w.msg configure -font \
-Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-*
}
pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
if {$data(-icon) != ""} {
label $w.bitmap -bitmap $data(-icon)
pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
}
# 5. Create a row of buttons at the bottom of the dialog.
set i 0
foreach but $buttons {
set name [lindex $but 0]
set opts [lrange $but 1 end]
if ![string compare $opts {}] {
# Capitalize the first letter of $name
set capName \
[string toupper \
[string index $name 0]][string range $name 1 end]
set opts [list -text $capName]
}
eval button $w.$name $opts -command [list "set tkPriv(button) $name"]
if ![string compare $name $data(-default)] {
frame $w.default -relief sunken -bd 1
raise $w.$name $w.default
pack $w.default -in $w.bot -side left -expand 1 -padx 3m -pady 2m
pack $w.$name -in $w.default -padx 2m -pady 2m
} else {
pack $w.$name -in $w.bot -side left -expand 1 \
-padx 3m -pady 2m
}
# create the binding for the key accelerator, based on the underline
#
set underIdx [$w.$name cget -under]
if {$underIdx >= 0} {
set key [string index [$w.$name cget -text] $underIdx]
bind $w <Alt-[string tolower $key]> "$w.$name invoke"
bind $w <Alt-[string toupper $key]> "$w.$name invoke"
}
incr i
}
# 6. Create a binding for <Return> on the dialog if there is a
# default button.
if [string compare $data(-default) ""] {
bind $w <Return> "tkButtonInvoke $w.$data(-default)"
}
# 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.
wm withdraw $w
update idletasks
set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
- [winfo vrootx [winfo parent $w]]]
set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
- [winfo vrooty [winfo parent $w]]]
wm geom $w +$x+$y
wm deiconify $w
# 8. Set a grab and claim the focus too.
set oldFocus [focus]
set oldGrab [grab current $w]
if {$oldGrab != ""} {
set grabStatus [grab status $oldGrab]
}
grab $w
if [string compare $data(-default) ""] {
focus $w.$data(-default)
} else {
focus $w
}
# 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.
tkwait variable tkPriv(button)
catch {focus $oldFocus}
destroy $w
if {$oldGrab != ""} {
if {$grabStatus == "global"} {
grab -global $oldGrab
} else {
grab $oldGrab
}
}
return $tkPriv(button)
}