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.4 2007/05/30 06:37:03 das 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# 16namespace eval ::tk::dialog {} 17 18image create bitmap ::tk::dialog::b1 -foreground black \ 19-data "#define b1_width 32\n#define b1_height 32 20static 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};" 32image create bitmap ::tk::dialog::b2 -foreground white \ 33-data "#define b2_width 32\n#define b2_height 32 34static 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};" 46image create bitmap ::tk::dialog::q -foreground blue \ 47-data "#define q_width 32\n#define q_height 32 48static 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};" 60image create bitmap ::tk::dialog::i -foreground blue \ 61-data "#define i_width 32\n#define i_height 32 62static 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};" 74image create bitmap ::tk::dialog::w1 -foreground black \ 75-data "#define w1_width 32\n#define w1_height 32 76static 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};" 88image create bitmap ::tk::dialog::w2 -foreground yellow \ 89-data "#define w2_width 32\n#define w2_height 32 90static 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};" 102image create bitmap ::tk::dialog::w3 -foreground black \ 103-data "#define w3_width 32\n#define w3_height 32 104static 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# 133proc ::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 option add *Dialog*background systemDialogBackgroundActive widgetDefault 170 option add *Dialog*Button.highlightBackground \ 171 systemDialogBackgroundActive widgetDefault 172 } 173 174 if {![winfo exists $data(-parent)]} { 175 error "bad window path name \"$data(-parent)\"" 176 } 177 178 switch -- $data(-type) { 179 abortretryignore { 180 set names [list abort retry ignore] 181 set labels [list &Abort &Retry &Ignore] 182 } 183 ok { 184 set names [list ok] 185 set labels {&OK} 186 } 187 okcancel { 188 set names [list ok cancel] 189 set labels [list &OK &Cancel] 190 } 191 retrycancel { 192 set names [list retry cancel] 193 set labels [list &Retry &Cancel] 194 } 195 yesno { 196 set names [list yes no] 197 set labels [list &Yes &No] 198 } 199 yesnocancel { 200 set names [list yes no cancel] 201 set labels [list &Yes &No &Cancel] 202 } 203 default { 204 error "bad -type value \"$data(-type)\": must be\ 205 abortretryignore, ok, okcancel, retrycancel,\ 206 yesno, or yesnocancel" 207 } 208 } 209 210 set buttons {} 211 foreach name $names lab $labels { 212 lappend buttons [list $name -text [mc $lab]] 213 } 214 215 # If no default button was specified, the default default is the 216 # first button (Bug: 2218). 217 218 if {$data(-default) eq ""} { 219 set data(-default) [lindex [lindex $buttons 0] 0] 220 } 221 222 set valid 0 223 foreach btn $buttons { 224 if {[lindex $btn 0] eq $data(-default)} { 225 set valid 1 226 break 227 } 228 } 229 if {!$valid} { 230 error "invalid default button \"$data(-default)\"" 231 } 232 233 # 2. Set the dialog to be a child window of $parent 234 # 235 # 236 if {$data(-parent) ne "."} { 237 set w $data(-parent).__tk__messagebox 238 } else { 239 set w .__tk__messagebox 240 } 241 242 # 3. Create the top-level window and divide it into top 243 # and bottom parts. 244 245 destroy $w 246 toplevel $w -class Dialog 247 wm title $w $data(-title) 248 wm iconname $w Dialog 249 wm protocol $w WM_DELETE_WINDOW { } 250 # There is only one background colour for the whole dialog 251 set bg [$w cget -background] 252 253 # Message boxes should be transient with respect to their parent so that 254 # they always stay on top of the parent window. But some window managers 255 # will simply create the child window as withdrawn if the parent is not 256 # viewable (because it is withdrawn or iconified). This is not good for 257 # "grab"bed windows. So only make the message box transient if the parent 258 # is viewable. 259 # 260 if {[winfo viewable [winfo toplevel $data(-parent)]] } { 261 wm transient $w $data(-parent) 262 } 263 264 if {$windowingsystem eq "classic" || $windowingsystem eq "aqua"} { 265 ::tk::unsupported::MacWindowStyle style $w moveableModal {} 266 } elseif {$windowingsystem eq "x11"} { 267 wm attributes $w -type dialog 268 } 269 270 frame $w.bot -background $bg 271 pack $w.bot -side bottom -fill both 272 frame $w.top -background $bg 273 pack $w.top -side top -fill both -expand 1 274 if {$windowingsystem ne "classic" && $windowingsystem ne "aqua"} { 275 $w.bot configure -relief raised -bd 1 276 $w.top configure -relief raised -bd 1 277 } 278 279 # 4. Fill the top part with bitmap and message (use the option 280 # database for -wraplength and -font so that they can be 281 # overridden by the caller). 282 283 option add *Dialog.msg.wrapLength 3i widgetDefault 284 if {$windowingsystem eq "classic" || $windowingsystem eq "aqua"} { 285 option add *Dialog.msg.font system widgetDefault 286 } else { 287 option add *Dialog.msg.font {Times 14} widgetDefault 288 } 289 290 label $w.msg -anchor nw -justify left -text $data(-message) \ 291 -background $bg 292 if {$data(-icon) ne ""} { 293 if {($windowingsystem eq "classic" || $windowingsystem eq "aqua") 294 || ([winfo depth $w] < 4) || $tk_strictMotif} { 295 label $w.bitmap -bitmap $data(-icon) -background $bg 296 } else { 297 canvas $w.bitmap -width 32 -height 32 -highlightthickness 0 \ 298 -background $bg 299 switch $data(-icon) { 300 error { 301 $w.bitmap create oval 0 0 31 31 -fill red -outline black 302 $w.bitmap create line 9 9 23 23 -fill white -width 4 303 $w.bitmap create line 9 23 23 9 -fill white -width 4 304 } 305 info { 306 $w.bitmap create image 0 0 -anchor nw \ 307 -image ::tk::dialog::b1 308 $w.bitmap create image 0 0 -anchor nw \ 309 -image ::tk::dialog::b2 310 $w.bitmap create image 0 0 -anchor nw \ 311 -image ::tk::dialog::i 312 } 313 question { 314 $w.bitmap create image 0 0 -anchor nw \ 315 -image ::tk::dialog::b1 316 $w.bitmap create image 0 0 -anchor nw \ 317 -image ::tk::dialog::b2 318 $w.bitmap create image 0 0 -anchor nw \ 319 -image ::tk::dialog::q 320 } 321 default { 322 $w.bitmap create image 0 0 -anchor nw \ 323 -image ::tk::dialog::w1 324 $w.bitmap create image 0 0 -anchor nw \ 325 -image ::tk::dialog::w2 326 $w.bitmap create image 0 0 -anchor nw \ 327 -image ::tk::dialog::w3 328 } 329 } 330 } 331 } 332 grid $w.bitmap $w.msg -in $w.top -sticky news -padx 2m -pady 2m 333 grid columnconfigure $w.top 1 -weight 1 334 grid rowconfigure $w.top 0 -weight 1 335 336 # 5. Create a row of buttons at the bottom of the dialog. 337 338 set i 0 339 foreach but $buttons { 340 set name [lindex $but 0] 341 set opts [lrange $but 1 end] 342 if {![llength $opts]} { 343 # Capitalize the first letter of $name 344 set capName [string toupper $name 0] 345 set opts [list -text $capName] 346 } 347 348 eval [list tk::AmpWidget button $w.$name -padx 3m] $opts \ 349 [list -command [list set tk::Priv(button) $name]] 350 351 if {$name eq $data(-default)} { 352 $w.$name configure -default active 353 } else { 354 $w.$name configure -default normal 355 } 356 grid $w.$name -in $w.bot -row 0 -column $i -padx 3m -pady 2m -sticky ew 357 grid columnconfigure $w.bot $i -uniform buttons 358 # We boost the size of some Mac buttons for l&f 359 if {$windowingsystem eq "classic" || $windowingsystem eq "aqua"} { 360 set tmp [string tolower $name] 361 if {$tmp eq "ok" || $tmp eq "cancel" || $tmp eq "yes" || 362 $tmp eq "no" || $tmp eq "abort" || $tmp eq "retry" || 363 $tmp eq "ignore"} { 364 grid columnconfigure $w.bot $i -minsize 90 365 } 366 grid configure $w.$name -pady 7 367 } 368 incr i 369 370 # create the binding for the key accelerator, based on the underline 371 # 372 # set underIdx [$w.$name cget -under] 373 # if {$underIdx >= 0} { 374 # set key [string index [$w.$name cget -text] $underIdx] 375 # bind $w <Alt-[string tolower $key]> [list $w.$name invoke] 376 # bind $w <Alt-[string toupper $key]> [list $w.$name invoke] 377 # } 378 } 379 bind $w <Alt-Key> [list ::tk::AltKeyInDialog $w %A] 380 381 if {$data(-default) ne ""} { 382 bind $w <FocusIn> { 383 if {"Button" eq [winfo class %W]} { 384 %W configure -default active 385 } 386 } 387 bind $w <FocusOut> { 388 if {"Button" eq [winfo class %W]} { 389 %W configure -default normal 390 } 391 } 392 } 393 394 # 6. Create a binding for <Return> on the dialog 395 396 bind $w <Return> { 397 if {"Button" eq [winfo class %W]} { 398 tk::ButtonInvoke %W 399 } 400 } 401 402 # 7. Withdraw the window, then update all the geometry information 403 # so we know how big it wants to be, then center the window in the 404 # display and de-iconify it. 405 406 ::tk::PlaceWindow $w widget $data(-parent) 407 408 # 8. Set a grab and claim the focus too. 409 410 if {$data(-default) ne ""} { 411 set focus $w.$data(-default) 412 } else { 413 set focus $w 414 } 415 ::tk::SetFocusGrab $w $focus 416 417 # 9. Wait for the user to respond, then restore the focus and 418 # return the index of the selected button. Restore the focus 419 # before deleting the window, since otherwise the window manager 420 # may take the focus away so we can't redirect it. Finally, 421 # restore any grab that was in effect. 422 423 vwait ::tk::Priv(button) 424 425 ::tk::RestoreFocusGrab $w $focus 426 427 return $Priv(button) 428} 429