Subversion Repositories or1k

# msgbox.tcl --

#

#       Implements messageboxes for platforms that do not have native

#       messagebox support.

#

# SCCS: @(#) msgbox.tcl 1.8 97/07/28 17:20:01

#

# 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.

#

# 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 tcl_platform

    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 "" "" ""}

        {-modal "" "" ""}

        {-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 {$tcl_platform(platform) == "macintosh"} {

        if {$data(-icon) == "error"} {

            set data(-icon) "stop"

        } elseif {$data(-icon) == "warning"} {

            set data(-icon) "caution"

        } elseif {$data(-icon) == "info"} {

            set data(-icon) "note"

        }

    }

    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)

    if {$tcl_platform(platform) == "macintosh"} {

        unsupported1 style $w dBoxProc

    }

    frame $w.bot

    pack $w.bot -side bottom -fill both

    frame $w.top

    pack $w.top -side top -fill both -expand 1

    if {$tcl_platform(platform) != "macintosh"} {

        $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 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)]} {

            $w.$name configure -default active

        }

        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"

        }

        # CYGNUS LOCAL - bind all buttons so that <Return>

        # activates them

        bind $w.$name <Return> "$w.$name invoke"

        incr i

    }

    # 6. Create a binding for <Return> on the dialog if there is a

    # default button.

    # CYGNUS LOCAL - This seems like a bad idea.  If the user

    # uses the keyboard to select something other than the default and

    # then hits <Return> to activate that button, the wrong value will

    # be returned

    #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)

}