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