mingw/lib/tk8.4/msgbox.tcl

   1 # msgbox.tcl --
   2 #
   3 #       Implements messageboxes for platforms that do not have native
   4 #       messagebox support.
   5 #
   6 # RCS: @(#) $Id: msgbox.tcl,v 1.24.2.3 2006/01/25 18:21:41 dgp Exp $
   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 # Ensure existence of ::tk::dialog namespace
  15 #
  16 namespace eval ::tk::dialog {}
  17
  18 image create bitmap ::tk::dialog::b1 -foreground black \
  19 -data "#define b1_width 32\n#define b1_height 32
  20 static unsigned char q1_bits[] = {
  21    0x00, 0xf8, 0x1f, 0x00, 0x00, 0x07, 0xe0, 0x00, 0xc0, 0x00, 0x00, 0x03,
  22    0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10,
  23    0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,
  24    0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
  25    0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
  26    0x01, 0x00, 0x00, 0x80, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,
  27    0x04, 0x00, 0x00, 0x20, 0x08, 0x00, 0x00, 0x10, 0x10, 0x00, 0x00, 0x08,
  28    0x60, 0x00, 0x00, 0x04, 0x80, 0x03, 0x80, 0x03, 0x00, 0x0c, 0x78, 0x00,
  29    0x00, 0x30, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00,
  30    0x00, 0x80, 0x04, 0x00, 0x00, 0x00, 0x05, 0x00, 0x00, 0x00, 0x06, 0x00,
  31    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
  32 image create bitmap ::tk::dialog::b2 -foreground white \
  33 -data "#define b2_width 32\n#define b2_height 32
  34 static unsigned char b2_bits[] = {
  35    0x00, 0x00, 0x00, 0x00, 0x00, 0xf8, 0x1f, 0x00, 0x00, 0xff, 0xff, 0x00,
  36    0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f,
  37    0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,
  38    0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
  39    0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
  40    0xfe, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,
  41    0xf8, 0xff, 0xff, 0x1f, 0xf0, 0xff, 0xff, 0x0f, 0xe0, 0xff, 0xff, 0x07,
  42    0x80, 0xff, 0xff, 0x03, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0xf0, 0x07, 0x00,
  43    0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00,
  44    0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
  45    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
  46 image create bitmap ::tk::dialog::q -foreground blue \
  47 -data "#define q_width 32\n#define q_height 32
  48 static unsigned char q_bits[] = {
  49    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  50    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x07, 0x00,
  51    0x00, 0x10, 0x0f, 0x00, 0x00, 0x18, 0x1e, 0x00, 0x00, 0x38, 0x1e, 0x00,
  52    0x00, 0x38, 0x1e, 0x00, 0x00, 0x10, 0x0f, 0x00, 0x00, 0x80, 0x07, 0x00,
  53    0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00,
  54    0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00,
  55    0x00, 0xe0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  56    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  57    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  58    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  59    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
  60 image create bitmap ::tk::dialog::i -foreground blue \
  61 -data "#define i_width 32\n#define i_height 32
  62 static unsigned char i_bits[] = {
  63    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  64    0x00, 0xe0, 0x01, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00,
  65    0x00, 0xe0, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  66    0x00, 0xf8, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,
  67    0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,
  68    0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xf0, 0x07, 0x00,
  69    0x00, 0xf8, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  70    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  71    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  72    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  73    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
  74 image create bitmap ::tk::dialog::w1 -foreground black \
  75 -data "#define w1_width 32\n#define w1_height 32
  76 static unsigned char w1_bits[] = {
  77    0x00, 0x80, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20, 0x04, 0x00,
  78    0x00, 0x10, 0x04, 0x00, 0x00, 0x10, 0x08, 0x00, 0x00, 0x08, 0x08, 0x00,
  79    0x00, 0x08, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x20, 0x00,
  80    0x00, 0x02, 0x20, 0x00, 0x00, 0x02, 0x40, 0x00, 0x00, 0x01, 0x40, 0x00,
  81    0x00, 0x01, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x00, 0x01,
  82    0x40, 0x00, 0x00, 0x01, 0x40, 0x00, 0x00, 0x02, 0x20, 0x00, 0x00, 0x02,
  83    0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08,
  84    0x08, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10, 0x04, 0x00, 0x00, 0x10,
  85    0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x20, 0x01, 0x00, 0x00, 0x40,
  86    0x01, 0x00, 0x00, 0x40, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20,
  87    0xfc, 0xff, 0xff, 0x1f, 0x00, 0x00, 0x00, 0x00};"
  88 image create bitmap ::tk::dialog::w2 -foreground yellow \
  89 -data "#define w2_width 32\n#define w2_height 32
  90 static unsigned char w2_bits[] = {
  91    0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,
  92    0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xf0, 0x07, 0x00,
  93    0x00, 0xf0, 0x0f, 0x00, 0x00, 0xf8, 0x0f, 0x00, 0x00, 0xf8, 0x1f, 0x00,
  94    0x00, 0xfc, 0x1f, 0x00, 0x00, 0xfc, 0x3f, 0x00, 0x00, 0xfe, 0x3f, 0x00,
  95    0x00, 0xfe, 0x7f, 0x00, 0x00, 0xff, 0x7f, 0x00, 0x00, 0xff, 0xff, 0x00,
  96    0x80, 0xff, 0xff, 0x00, 0x80, 0xff, 0xff, 0x01, 0xc0, 0xff, 0xff, 0x01,
  97    0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07,
  98    0xf0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f, 0xf8, 0xff, 0xff, 0x0f,
  99    0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x1f, 0xfe, 0xff, 0xff, 0x3f,
 100    0xfe, 0xff, 0xff, 0x3f, 0xfe, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x1f,
 101    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
 102 image create bitmap ::tk::dialog::w3 -foreground black \
 103 -data "#define w3_width 32\n#define w3_height 32
 104 static unsigned char w3_bits[] = {
 105    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
 106    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
 107    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
 108    0x00, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,
 109    0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,
 110    0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00,
 111    0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00,
 112    0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,
 113    0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00,
 114    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
 115    0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
 116
 117 # ::tk::MessageBox --
 118 #
 119 #       Pops up a messagebox with an application-supplied message with
 120 #       an icon and a list of buttons. This procedure will be called
 121 #       by tk_messageBox if the platform does not have native
 122 #       messagebox support, or if the particular type of messagebox is
 123 #       not supported natively.
 124 #
 125 #       Color icons are used on Unix displays that have a color
 126 #       depth of 4 or more and $tk_strictMotif is not on.
 127 #
 128 #       This procedure is a private procedure shouldn't be called
 129 #       directly. Call tk_messageBox instead.
 130 #
 131 #       See the user documentation for details on what tk_messageBox does.
 132 #
 133 proc ::tk::MessageBox {args} {
 134     global tcl_platform tk_strictMotif
 135     variable ::tk::Priv
 136
 137     set w ::tk::PrivMsgBox
 138     upvar $w data
 139
 140     #
 141     # The default value of the title is space (" ") not the empty string
 142     # because for some window managers, a
 143     #           wm title .foo ""
 144     # causes the window title to be "foo" instead of the empty string.
 145     #
 146     set specs {
 147         {-default "" "" ""}
 148         {-icon "" "" "info"}
 149         {-message "" "" ""}
 150         {-parent "" "" .}
 151         {-title "" "" " "}
 152         {-type "" "" "ok"}
 153     }
 154
 155     tclParseConfigSpec $w $specs "" $args
 156
 157     if {[lsearch -exact {info warning error question} $data(-icon)] == -1} {
 158         error "bad -icon value \"$data(-icon)\": must be error, info, question, or warning"
 159     }
 160
 161     # Store tk windowingsystem to avoid too many calls
 162     set windowingsystem [tk windowingsystem]
 163     if {$windowingsystem eq "classic" || $windowingsystem eq "aqua"} {
 164         switch -- $data(-icon) {
 165             "error"     {set data(-icon) "stop"}
 166             "warning"   {set data(-icon) "caution"}
 167             "info"      {set data(-icon) "note"}
 168         }
 169     }
 170
 171     if {![winfo exists $data(-parent)]} {
 172         error "bad window path name \"$data(-parent)\""
 173     }
 174
 175     switch -- $data(-type) {
 176         abortretryignore {
 177             set names [list abort retry ignore]
 178             set labels [list &Abort &Retry &Ignore]
 179         }
 180         ok {
 181             set names [list ok]
 182             set labels {&OK}
 183         }
 184         okcancel {
 185             set names [list ok cancel]
 186             set labels [list &OK &Cancel]
 187         }
 188         retrycancel {
 189             set names [list retry cancel]
 190             set labels [list &Retry &Cancel]
 191         }
 192         yesno {
 193             set names [list yes no]
 194             set labels [list &Yes &No]
 195         }
 196         yesnocancel {
 197             set names [list yes no cancel]
 198             set labels [list &Yes &No &Cancel]
 199         }
 200         default {
 201             error "bad -type value \"$data(-type)\": must be\
 202                     abortretryignore, ok, okcancel, retrycancel,\
 203                     yesno, or yesnocancel"
 204         }
 205     }
 206
 207     set buttons {}
 208     foreach name $names lab $labels {
 209         lappend buttons [list $name -text [mc $lab]]
 210     }
 211
 212     # If no default button was specified, the default default is the
 213     # first button (Bug: 2218).
 214
 215     if {$data(-default) eq ""} {
 216         set data(-default) [lindex [lindex $buttons 0] 0]
 217     }
 218
 219     set valid 0
 220     foreach btn $buttons {
 221         if {[lindex $btn 0] eq $data(-default)} {
 222             set valid 1
 223             break
 224         }
 225     }
 226     if {!$valid} {
 227         error "invalid default button \"$data(-default)\""
 228     }
 229
 230     # 2. Set the dialog to be a child window of $parent
 231     #
 232     #
 233     if {$data(-parent) ne "."} {
 234         set w $data(-parent).__tk__messagebox
 235     } else {
 236         set w .__tk__messagebox
 237     }
 238
 239     # 3. Create the top-level window and divide it into top
 240     # and bottom parts.
 241
 242     destroy $w
 243     toplevel $w -class Dialog
 244     wm title $w $data(-title)
 245     wm iconname $w Dialog
 246     wm protocol $w WM_DELETE_WINDOW { }
 247     # There is only one background colour for the whole dialog
 248     set bg [$w cget -background]
 249
 250     # Message boxes should be transient with respect to their parent so that
 251     # they always stay on top of the parent window.  But some window managers
 252     # will simply create the child window as withdrawn if the parent is not
 253     # viewable (because it is withdrawn or iconified).  This is not good for
 254     # "grab"bed windows.  So only make the message box transient if the parent
 255     # is viewable.
 256     #
 257     if {[winfo viewable [winfo toplevel $data(-parent)]] } {
 258         wm transient $w $data(-parent)
 259     }
 260
 261     if {$windowingsystem eq "classic" || $windowingsystem eq "aqua"} {
 262         unsupported::MacWindowStyle style $w dBoxProc
 263     }
 264
 265     frame $w.bot -background $bg
 266     pack $w.bot -side bottom -fill both
 267     frame $w.top -background $bg
 268     pack $w.top -side top -fill both -expand 1
 269     if {$windowingsystem ne "classic" && $windowingsystem ne "aqua"} {
 270         $w.bot configure -relief raised -bd 1
 271         $w.top configure -relief raised -bd 1
 272     }
 273
 274     # 4. Fill the top part with bitmap and message (use the option
 275     # database for -wraplength and -font so that they can be
 276     # overridden by the caller).
 277
 278     option add *Dialog.msg.wrapLength 3i widgetDefault
 279     if {$windowingsystem eq "classic" || $windowingsystem eq "aqua"} {
 280         option add *Dialog.msg.font system widgetDefault
 281     } else {
 282         option add *Dialog.msg.font {Times 14} widgetDefault
 283     }
 284
 285     label $w.msg -anchor nw -justify left -text $data(-message) \
 286             -background $bg
 287     if {$data(-icon) ne ""} {
 288         if {($windowingsystem eq "classic" || $windowingsystem eq "aqua")
 289                 || ([winfo depth $w] < 4) || $tk_strictMotif} {
 290             label $w.bitmap -bitmap $data(-icon) -background $bg
 291         } else {
 292             canvas $w.bitmap -width 32 -height 32 -highlightthickness 0 \
 293                     -background $bg
 294             switch $data(-icon) {
 295                 error {
 296                     $w.bitmap create oval 0 0 31 31 -fill red -outline black
 297                     $w.bitmap create line 9 9 23 23 -fill white -width 4
 298                     $w.bitmap create line 9 23 23 9 -fill white -width 4
 299                 }
 300                 info {
 301                     $w.bitmap create image 0 0 -anchor nw \
 302                             -image ::tk::dialog::b1
 303                     $w.bitmap create image 0 0 -anchor nw \
 304                             -image ::tk::dialog::b2
 305                     $w.bitmap create image 0 0 -anchor nw \
 306                             -image ::tk::dialog::i
 307                 }
 308                 question {
 309                     $w.bitmap create image 0 0 -anchor nw \
 310                             -image ::tk::dialog::b1
 311                     $w.bitmap create image 0 0 -anchor nw \
 312                             -image ::tk::dialog::b2
 313                     $w.bitmap create image 0 0 -anchor nw \
 314                             -image ::tk::dialog::q
 315                 }
 316                 default {
 317                     $w.bitmap create image 0 0 -anchor nw \
 318                             -image ::tk::dialog::w1
 319                     $w.bitmap create image 0 0 -anchor nw \
 320                             -image ::tk::dialog::w2
 321                     $w.bitmap create image 0 0 -anchor nw \
 322                             -image ::tk::dialog::w3
 323                 }
 324             }
 325         }
 326     }
 327     grid $w.bitmap $w.msg -in $w.top -sticky news -padx 2m -pady 2m
 328     grid columnconfigure $w.top 1 -weight 1
 329     grid rowconfigure $w.top 0 -weight 1
 330
 331     # 5. Create a row of buttons at the bottom of the dialog.
 332
 333     set i 0
 334     foreach but $buttons {
 335         set name [lindex $but 0]
 336         set opts [lrange $but 1 end]
 337         if {![llength $opts]} {
 338             # Capitalize the first letter of $name
 339             set capName [string toupper $name 0]
 340             set opts [list -text $capName]
 341         }
 342
 343         eval [list tk::AmpWidget button $w.$name -padx 3m] $opts \
 344                 [list -command [list set tk::Priv(button) $name]]
 345
 346         if {$name eq $data(-default)} {
 347             $w.$name configure -default active
 348         } else {
 349             $w.$name configure -default normal
 350         }
 351         grid $w.$name -in $w.bot -row 0 -column $i -padx 3m -pady 2m -sticky ew
 352         grid columnconfigure $w.bot $i -uniform buttons
 353         incr i
 354
 355         # create the binding for the key accelerator, based on the underline
 356         #
 357         # set underIdx [$w.$name cget -under]
 358         # if {$underIdx >= 0} {
 359         #     set key [string index [$w.$name cget -text] $underIdx]
 360         #     bind $w <Alt-[string tolower $key]>  [list $w.$name invoke]
 361         #     bind $w <Alt-[string toupper $key]>  [list $w.$name invoke]
 362         # }
 363     }
 364     bind $w <Alt-Key> [list ::tk::AltKeyInDialog $w %A]
 365
 366     if {$data(-default) ne ""} {
 367         bind $w <FocusIn> {
 368             if {"Button" eq [winfo class %W]} {
 369                 %W configure -default active
 370             }
 371         }
 372         bind $w <FocusOut> {
 373             if {"Button" eq [winfo class %W]} {
 374                 %W configure -default normal
 375             }
 376         }
 377     }
 378
 379     # 6. Create a binding for <Return> on the dialog
 380
 381     bind $w <Return> {
 382         if {"Button" eq [winfo class %W]} {
 383             tk::ButtonInvoke %W
 384         }
 385     }
 386
 387     # 7. Withdraw the window, then update all the geometry information
 388     # so we know how big it wants to be, then center the window in the
 389     # display and de-iconify it.
 390
 391     ::tk::PlaceWindow $w widget $data(-parent)
 392
 393     # 8. Set a grab and claim the focus too.
 394
 395     if {$data(-default) ne ""} {
 396         set focus $w.$data(-default)
 397     } else {
 398         set focus $w
 399     }
 400     ::tk::SetFocusGrab $w $focus
 401
 402     # 9. Wait for the user to respond, then restore the focus and
 403     # return the index of the selected button.  Restore the focus
 404     # before deleting the window, since otherwise the window manager
 405     # may take the focus away so we can't redirect it.  Finally,
 406     # restore any grab that was in effect.
 407
 408     vwait ::tk::Priv(button)
 409
 410     ::tk::RestoreFocusGrab $w $focus
 411
 412     return $Priv(button)
 413 }