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