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