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