246 lines
6.5 KiB
Tcl
246 lines
6.5 KiB
Tcl
|
# 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)
|
||
|
|
}
|