diff options
Diffstat (limited to 'tk/library/msgbox.tcl')
| -rw-r--r-- | tk/library/msgbox.tcl | 159 |
1 files changed, 83 insertions, 76 deletions
diff --git a/tk/library/msgbox.tcl b/tk/library/msgbox.tcl index 1e6744f629f..20862b5b117 100644 --- a/tk/library/msgbox.tcl +++ b/tk/library/msgbox.tcl @@ -114,7 +114,7 @@ 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};" -# tkMessageBox -- +# ::tk::MessageBox -- # # Pops up a messagebox with an application-supplied message with # an icon and a list of buttons. This procedure will be called @@ -130,11 +130,12 @@ static unsigned char w3_bits[] = { # # See the user documentation for details on what tk_messageBox does. # -proc tkMessageBox {args} { - global tkPriv tcl_platform tk_strictMotif +proc ::tk::MessageBox {args} { + global tcl_platform tk_strictMotif + variable ::tk::Priv - set w tkPrivMsgBox - upvar #0 $w data + set w ::tk::PrivMsgBox + upvar $w data # # The default value of the title is space (" ") not the empty string @@ -146,7 +147,6 @@ proc tkMessageBox {args} { {-default "" "" ""} {-icon "" "" "info"} {-message "" "" ""} - {-modal "" "" ""} {-parent "" "" .} {-title "" "" " "} {-type "" "" "ok"} @@ -157,7 +157,8 @@ proc tkMessageBox {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 $tcl_platform(platform) "macintosh"]} { + if {[string equal [tk windowingsystem] "classic"] + || [string equal [tk windowingsystem] "aqua"]} { switch -- $data(-icon) { "error" {set data(-icon) "stop"} "warning" {set data(-icon) "caution"} @@ -170,63 +171,64 @@ proc tkMessageBox {args} { } switch -- $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} - } + abortretryignore { + set names [list abort retry ignore] + set labels [list &Abort &Retry &Ignore] } ok { - set buttons { - {ok -width 6 -text OK -under 0} - } - if {[string equal $data(-default) ""]} { - set data(-default) "ok" - } + set names [list ok] + set labels {&OK} } okcancel { - set buttons { - {ok -width 6 -text OK -under 0} - {cancel -width 6 -text Cancel -under 0} - } + set names [list ok cancel] + set labels [list &OK &Cancel] } retrycancel { - set buttons { - {retry -width 6 -text Retry -under 0} - {cancel -width 6 -text Cancel -under 0} - } + set names [list retry cancel] + set labels [list &Retry &Cancel] } yesno { - set buttons { - {yes -width 6 -text Yes -under 0} - {no -width 6 -text No -under 0} - } + set names [list yes no] + set labels [list &Yes &No] } yesnocancel { - set buttons { - {yes -width 6 -text Yes -under 0} - {no -width 6 -text No -under 0} - {cancel -width 6 -text Cancel -under 0} - } + set names [list yes no cancel] + set labels [list &Yes &No &Cancel] } default { - error "bad -type value \"$data(-type)\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel" + error "bad -type value \"$data(-type)\": must be\ + abortretryignore, ok, okcancel, retrycancel,\ + yesno, or yesnocancel" } } + + set maxWidth [eval mcmaxamp $labels] + if {$maxWidth <6} { + set maxWidth 6 + } - if {[string compare $data(-default) ""]} { - set valid 0 - foreach btn $buttons { - if {[string equal [lindex $btn 0] $data(-default)]} { - set valid 1 - break - } - } - if {!$valid} { - error "invalid default button \"$data(-default)\"" + set buttons {} + foreach name $names lab $labels { + lappend buttons [list $name -width $maxWidth -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] + } + + set valid 0 + foreach btn $buttons { + if {[string equal [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 # @@ -245,6 +247,8 @@ proc tkMessageBox {args} { wm title $w $data(-title) wm iconname $w Dialog 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 @@ -253,19 +257,21 @@ proc tkMessageBox {args} { # "grab"bed windows. So only make the message box transient if the parent # is viewable. # - if { [winfo viewable [winfo toplevel $data(-parent)]] } { + if {[winfo viewable [winfo toplevel $data(-parent)]] } { wm transient $w $data(-parent) } - if {[string equal $tcl_platform(platform) "macintosh"]} { - unsupported1 style $w dBoxProc + if {[string equal [tk windowingsystem] "classic"] + || [string equal [tk windowingsystem] "aqua"]} { + unsupported::MacWindowStyle style $w dBoxProc } - frame $w.bot + frame $w.bot -background $bg pack $w.bot -side bottom -fill both - frame $w.top + frame $w.top -background $bg pack $w.top -side top -fill both -expand 1 - if {[string compare $tcl_platform(platform) "macintosh"]} { + 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 } @@ -275,19 +281,23 @@ proc tkMessageBox {args} { # overridden by the caller). option add *Dialog.msg.wrapLength 3i widgetDefault - if {[string equal $tcl_platform(platform) "macintosh"]} { + if {[string equal [tk windowingsystem] "classic"] + || [string equal [tk windowingsystem] "aqua"]} { option add *Dialog.msg.font system widgetDefault } else { option add *Dialog.msg.font {Times 18} widgetDefault } - label $w.msg -anchor nw -justify left -text $data(-message) + label $w.msg -anchor nw -justify left -text $data(-message) \ + -background $bg if {[string compare $data(-icon) ""]} { - if {[string equal $tcl_platform(platform) "macintosh"] \ + if {([string equal [tk windowingsystem] "classic"] + || [string equal [tk windowingsystem] "aqua"]) || ([winfo depth $w] < 4) || $tk_strictMotif} { - label $w.bitmap -bitmap $data(-icon) + label $w.bitmap -bitmap $data(-icon) -background $bg } else { - canvas $w.bitmap -width 32 -height 32 -highlightthickness 0 + canvas $w.bitmap -width 32 -height 32 -highlightthickness 0 \ + -background $bg switch $data(-icon) { error { $w.bitmap create oval 0 0 31 31 -fill red -outline black @@ -337,28 +347,27 @@ proc tkMessageBox {args} { set opts [list -text $capName] } - eval button [list $w.$name] $opts [list -command [list set tkPriv(button) $name]] + eval [list tk::AmpWidget button $w.$name] $opts \ + [list -command [list set tk::Priv(button) $name]] if {[string equal $name $data(-default)]} { $w.$name configure -default active + } else { + $w.$name configure -default normal } 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]> [list $w.$name invoke] - bind $w <Alt-[string toupper $key]> [list $w.$name invoke] - } - - # CYGNUS LOCAL - bind all buttons so that <Return> - # activates them - bind $w.$name <Return> "$w.$name invoke" - - incr i + # set underIdx [$w.$name cget -under] + # if {$underIdx >= 0} { + # 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] + # } + # incr i } + bind $w <Alt-Key> [list ::tk::AltKeyInDialog $w %A] if {[string compare {} $data(-default)]} { bind $w <FocusIn> { @@ -377,7 +386,7 @@ proc tkMessageBox {args} { bind $w <Return> { if {[string equal Button [winfo class %W]]} { - tkButtonInvoke %W + tk::ButtonInvoke %W } } @@ -402,11 +411,9 @@ proc tkMessageBox {args} { # may take the focus away so we can't redirect it. Finally, # restore any grab that was in effect. - tkwait variable tkPriv(button) + vwait ::tk::Priv(button) ::tk::RestoreFocusGrab $w $focus - return $tkPriv(button) + return $Priv(button) } - - |