SGI/util/SGI/lib/tk8.0/msgbox.tcl

   1 # msgbox.tcl --
   2 #
   3 #       Implements messageboxes for platforms that do not have native
   4 #       messagebox support.
   5 #
   6 # SCCS: @(#) msgbox.tcl 1.8 97/07/28 17:20:01
   7 #
   8 # Copyright (c) 1994-1997 Sun Microsystems, Inc.
   9 #
  10 # See the file "license.terms" for information on usage and redistribution
  11 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12 #
  13
  14
  15 # tkMessageBox --
  16 #
  17 #       Pops up a messagebox with an application-supplied message with
  18 #       an icon and a list of buttons. This procedure will be called
  19 #       by tk_messageBox if the platform does not have native
  20 #       messagebox support, or if the particular type of messagebox is
  21 #       not supported natively.
  22 #
  23 #       This procedure is a private procedure shouldn't be called
  24 #       directly. Call tk_messageBox instead.
  25 #
  26 #       See the user documentation for details on what tk_messageBox does.
  27 #
  28 proc tkMessageBox {args} {
  29     global tkPriv tcl_platform
  30
  31     set w tkPrivMsgBox
  32     upvar #0 $w data
  33
  34     #
  35     # The default value of the title is space (" ") not the empty string
  36     # because for some window managers, a
  37     #           wm title .foo ""
  38     # causes the window title to be "foo" instead of the empty string.
  39     #
  40     set specs {
  41         {-default "" "" ""}
  42         {-icon "" "" "info"}
  43         {-message "" "" ""}
  44         {-parent "" "" .}
  45         {-title "" "" " "}
  46         {-type "" "" "ok"}
  47     }
  48
  49     tclParseConfigSpec $w $specs "" $args
  50
  51     if {[lsearch {info warning error question} $data(-icon)] == -1} {
  52         error "invalid icon \"$data(-icon)\", must be error, info, question or warning"
  53     }
  54     if {$tcl_platform(platform) == "macintosh"} {
  55         if {$data(-icon) == "error"} {
  56             set data(-icon) "stop"
  57         } elseif {$data(-icon) == "warning"} {
  58             set data(-icon) "caution"
  59         } elseif {$data(-icon) == "info"} {
  60             set data(-icon) "note"
  61         }
  62     }
  63
  64     if ![winfo exists $data(-parent)] {
  65         error "bad window path name \"$data(-parent)\""
  66     }
  67
  68     case $data(-type) {
  69         abortretryignore {
  70             set buttons {
  71                 {abort  -width 6 -text Abort -under 0}
  72                 {retry  -width 6 -text Retry -under 0}
  73                 {ignore -width 6 -text Ignore -under 0}
  74             }
  75         }
  76         ok {
  77             set buttons {
  78                 {ok -width 6 -text OK -under 0}
  79             }
  80             if {$data(-default) == ""} {
  81                 set data(-default) "ok"
  82             }
  83         }
  84         okcancel {
  85             set buttons {
  86                 {ok     -width 6 -text OK     -under 0}
  87                 {cancel -width 6 -text Cancel -under 0}
  88             }
  89         }
  90         retrycancel {
  91             set buttons {
  92                 {retry  -width 6 -text Retry  -under 0}
  93                 {cancel -width 6 -text Cancel -under 0}
  94             }
  95         }
  96         yesno {
  97             set buttons {
  98                 {yes    -width 6 -text Yes -under 0}
  99                 {no     -width 6 -text No  -under 0}
 100             }
 101         }
 102         yesnocancel {
 103             set buttons {
 104                 {yes    -width 6 -text Yes -under 0}
 105                 {no     -width 6 -text No  -under 0}
 106                 {cancel -width 6 -text Cancel -under 0}
 107             }
 108         }
 109         default {
 110             error "invalid message box type \"$data(-type)\", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel"
 111         }
 112     }
 113
 114     if [string compare $data(-default) ""] {
 115         set valid 0
 116         foreach btn $buttons {
 117             if ![string compare [lindex $btn 0] $data(-default)] {
 118                 set valid 1
 119                 break
 120             }
 121         }
 122         if !$valid {
 123             error "invalid default button \"$data(-default)\""
 124         }
 125     }
 126
 127     # 2. Set the dialog to be a child window of $parent
 128     #
 129     #
 130     if [string compare $data(-parent) .] {
 131         set w $data(-parent).__tk__messagebox
 132     } else {
 133         set w .__tk__messagebox
 134     }
 135
 136     # 3. Create the top-level window and divide it into top
 137     # and bottom parts.
 138
 139     catch {destroy $w}
 140     toplevel $w -class Dialog
 141     wm title $w $data(-title)
 142     wm iconname $w Dialog
 143     wm protocol $w WM_DELETE_WINDOW { }
 144     wm transient $w $data(-parent)
 145     if {$tcl_platform(platform) == "macintosh"} {
 146         unsupported1 style $w dBoxProc
 147     }
 148
 149     frame $w.bot
 150     pack $w.bot -side bottom -fill both
 151     frame $w.top
 152     pack $w.top -side top -fill both -expand 1
 153     if {$tcl_platform(platform) != "macintosh"} {
 154         $w.bot configure -relief raised -bd 1
 155         $w.top configure -relief raised -bd 1
 156     }
 157
 158     # 4. Fill the top part with bitmap and message (use the option
 159     # database for -wraplength so that it can be overridden by
 160     # the caller).
 161
 162     option add *Dialog.msg.wrapLength 3i widgetDefault
 163     label $w.msg -justify left -text $data(-message)
 164     catch {$w.msg configure -font \
 165                 -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-*
 166     }
 167     pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
 168     if {$data(-icon) != ""} {
 169         label $w.bitmap -bitmap $data(-icon)
 170         pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
 171     }
 172
 173     # 5. Create a row of buttons at the bottom of the dialog.
 174
 175     set i 0
 176     foreach but $buttons {
 177         set name [lindex $but 0]
 178         set opts [lrange $but 1 end]
 179         if ![string compare $opts {}] {
 180             # Capitalize the first letter of $name
 181             set capName \
 182                 [string toupper \
 183                     [string index $name 0]][string range $name 1 end]
 184             set opts [list -text $capName]
 185         }
 186
 187         eval button $w.$name $opts -command [list "set tkPriv(button) $name"]
 188
 189         if ![string compare $name $data(-default)] {
 190             $w.$name configure -default active
 191         }
 192         pack $w.$name -in $w.bot -side left -expand 1 \
 193             -padx 3m -pady 2m
 194
 195         # create the binding for the key accelerator, based on the underline
 196         #
 197         set underIdx [$w.$name cget -under]
 198         if {$underIdx >= 0} {
 199             set key [string index [$w.$name cget -text] $underIdx]
 200             bind $w <Alt-[string tolower $key]>  "$w.$name invoke"
 201             bind $w <Alt-[string toupper $key]>  "$w.$name invoke"
 202         }
 203         incr i
 204     }
 205
 206     # 6. Create a binding for <Return> on the dialog if there is a
 207     # default button.
 208
 209     if [string compare $data(-default) ""] {
 210         bind $w <Return> "tkButtonInvoke $w.$data(-default)"
 211     }
 212
 213     # 7. Withdraw the window, then update all the geometry information
 214     # so we know how big it wants to be, then center the window in the
 215     # display and de-iconify it.
 216
 217     wm withdraw $w
 218     update idletasks
 219     set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
 220             - [winfo vrootx [winfo parent $w]]]
 221     set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
 222             - [winfo vrooty [winfo parent $w]]]
 223     wm geom $w +$x+$y
 224     wm deiconify $w
 225
 226     # 8. Set a grab and claim the focus too.
 227
 228     set oldFocus [focus]
 229     set oldGrab [grab current $w]
 230     if {$oldGrab != ""} {
 231         set grabStatus [grab status $oldGrab]
 232     }
 233     grab $w
 234     if [string compare $data(-default) ""] {
 235         focus $w.$data(-default)
 236     } else {
 237         focus $w
 238     }
 239
 240     # 9. Wait for the user to respond, then restore the focus and
 241     # return the index of the selected button.  Restore the focus
 242     # before deleting the window, since otherwise the window manager
 243     # may take the focus away so we can't redirect it.  Finally,
 244     # restore any grab that was in effect.
 245
 246     tkwait variable tkPriv(button)
 247     catch {focus $oldFocus}
 248     destroy $w
 249     if {$oldGrab != ""} {
 250         if {$grabStatus == "global"} {
 251             grab -global $oldGrab
 252         } else {
 253             grab $oldGrab
 254         }
 255     }
 256     return $tkPriv(button)
 257 }