1# -*- tcl -*- 2# 3# dialog.tcl - 4# 5# Generic dialog widget (themed) 6# 7# RCS: @(#) $Id: dialog.tcl,v 1.23 2010/06/01 18:06:52 hobbs Exp $ 8# 9 10# Creation and Options - widget::dialog $path ... 11# -command -default {} ; # gets appended: $win $reason 12# -focus -default {} ; # subwindow to set focus on display 13# -modal -default none 14# -padding -default 0 15# -parent -default "" 16# -place -default center 17# -separator -default 1 18# -synchronous -default 1 19# -title -default "" 20# -transient -default 1 21# -type -default custom ; # {ok okcancel okcancelapply custom} 22# -timeout -default 0 ; # only active with -synchronous 23# 24# Methods 25# $path add $what $args... => $id 26# $path getframe => $frame 27# $path setwidget $widget => "" 28# $path display 29# $path cancel 30# $path withdraw 31# 32# Bindings 33# Escape => invokes [$dlg close cancel] 34# WM_DELETE_WINDOW => invokes [$dlg close cancel] 35# 36 37if 0 { 38 # Samples 39 package require widget::dialog 40 set dlg [widget::dialog .pkgerr -modal local -separator 1 \ 41 -place right -parent . -type okcancel \ 42 -title "Dialog Title"] 43 set frame [frame $dlg.f] 44 label $frame.lbl -text "Type Something In:" 45 entry $frame.ent 46 grid $frame.lbl $frame.ent -sticky ew 47 grid columnconfigure $frame 1 -weight 1 48 $dlg setwidget $frame 49 puts [$dlg display] 50 destroy $dlg 51 52 # Using -synchronous with a -type custom dialog requires that the 53 # custom buttons call [$dlg close $reason] to trigger the close 54 set dlg [widget::dialog .pkgerr -title "Yes/No Dialog" -separator 1 \ 55 -parent . -type custom] 56 set frame [frame $dlg.f] 57 label $frame.lbl -text "Type Something In:" 58 entry $frame.ent 59 grid $frame.lbl $frame.ent -sticky ew 60 grid columnconfigure $frame 1 -weight 1 61 $dlg setwidget $frame 62 $dlg add button -text "Yes" -command [list $dlg close yes] 63 $dlg add button -text "No" -command [list $dlg close no] 64 puts [$dlg display] 65} 66 67# ### ######### ########################### 68## Prerequisites 69 70#package require image ; # bitmaps 71package require snit ; # object system 72package require msgcat 73 74# ### ######### ########################### 75## Implementation 76 77snit::widget widget::dialog { 78 # ### ######### ########################### 79 hulltype toplevel 80 81 component frame 82 component separator 83 component buttonbox 84 85 delegate option -padding to frame; 86 delegate option * to hull 87 delegate method * to hull 88 89 option -command -default {}; 90 # {none local global} 91 option -modal -default none -configuremethod C-modal; 92 #option -padding -default 0 -configuremethod C-padding; 93 option -parent -default "" -configuremethod C-parent; 94 # {none center left right above below over} 95 option -place -default center -configuremethod C-place; 96 option -separator -default 1 -configuremethod C-separator; 97 option -synchronous -default 1; 98 option -title -default "" -configuremethod C-title; 99 option -transient -default 1 -configuremethod C-transient; 100 option -type -default custom -configuremethod C-type; 101 option -timeout -default 0; 102 option -focus -default ""; 103 104 # We may make this an easier customizable messagebox, but not yet 105 #option -anchor c; # {n e w s c} 106 #option -text ""; 107 #option -bitmap ""; 108 #option -image ""; 109 110 # ### ######### ########################### 111 ## Public API. Construction 112 113 constructor {args} { 114 wm withdraw $win 115 116 install frame using ttk::frame $win._frame 117 install separator using ttk::separator $win._separator \ 118 -orient horizontal 119 if {[tk windowingsystem] eq "aqua"} { 120 # left top right bottom - Aqua corner resize control padding 121 set btnpad [list 0 6 14 4] 122 } else { 123 # left top right bottom 124 set btnpad [list 0 6 0 4] 125 } 126 install buttonbox using ttk::frame $win._buttonbox -padding $btnpad 127 128 grid $frame -row 0 -column 0 -sticky news 129 grid $separator -row 1 -column 0 -sticky ew 130 # Should padding effect the buttonbox? 131 grid $buttonbox -row 2 -column 0 -sticky ew 132 133 grid columnconfigure $win 0 -weight 1 134 grid rowconfigure $win 0 -weight 1 135 136 # Default to invoking no/cancel/withdraw 137 wm protocol $win WM_DELETE_WINDOW [mymethod close cancel] 138 bind $win <Key-Escape> [mymethod close cancel] 139 # Ensure grab release on unmap? 140 #bind $win <Unmap> [list grab release $win] 141 142 # Handle defaults 143 if {!$options(-separator)} { 144 grid remove $separator 145 } 146 147 $self configurelist $args 148 } 149 150 # ### ######### ########################### 151 ## Public API. Extend container by application specific content. 152 153 # getframe and setwidget are somewhat mutually exlusive. 154 # Use one or the other. 155 method getframe {} { 156 return $frame 157 } 158 159 method setwidget {w} { 160 if {[winfo exists $setwidget]} { 161 grid remove $setwidget 162 set setwidget {} 163 } 164 if {[winfo exists $w]} { 165 grid $w -in $frame -row 0 -column 0 -sticky news 166 grid columnconfigure $frame 0 -weight 1 167 grid rowconfigure $frame 0 -weight 1 168 set setwidget $w 169 } 170 } 171 172 variable uid 0 173 method add {what args} { 174 if {$what eq "button"} { 175 set w [eval [linsert $args 0 ttk::button $buttonbox._b[incr uid]]] 176 } elseif {[winfo exists $what]} { 177 set w $what 178 } else { 179 return -code error "unknown add type \"$what\", must be:\ 180 button or a pathname" 181 } 182 set col [lindex [grid size $buttonbox] 0]; # get last column 183 if {$col == 0} { 184 # ensure weighted 0 column 185 grid columnconfigure $buttonbox 0 -weight 1 186 incr col 187 } 188 grid $w -row 0 -column $col -sticky ew -padx 4 189 return $w 190 } 191 192 method display {} { 193 set lastFocusGrab [focus] 194 set last [grab current $win] 195 lappend lastFocusGrab $last 196 if {[winfo exists $last]} { 197 lappend lastFocusGrab [grab status $last] 198 } 199 200 $self PlaceWindow $win $options(-place) $options(-parent) 201 if {$options(-modal) ne "none"} { 202 if {$options(-modal) eq "global"} { 203 catch {grab -global $win} 204 } else { 205 catch {grab $win} 206 } 207 } 208 if {[winfo exists $options(-focus)]} { 209 catch { focus $options(-focus) } 210 } 211 # In order to allow !custom synchronous, we need to allow 212 # custom dialogs to set [myvar result]. They do that through 213 # [$dlg close $reason] 214 if {$options(-synchronous)} { 215 if {$options(-timeout) > 0} { 216 # set var after specified timeout 217 set timeout_id [after $options(-timeout) \ 218 [list set [myvar result] timeout]] 219 } 220 vwait [myvar result] 221 catch {after cancel $timeout_id} 222 # A synchronous dialog will always withdraw, even if a -command 223 # tries to return a break code. 224 return [$self withdraw $result] 225 } 226 } 227 228 method close {{reason {}}} { 229 set code 0 230 if {$options(-command) ne ""} { 231 set cmd $options(-command) 232 lappend cmd $win $reason 233 set code [catch {uplevel \#0 $cmd} result] 234 } else { 235 # set result to trigger any possible vwait 236 set result $reason 237 } 238 if {$code == 3} { 239 # 'break' return code - don't withdraw 240 return $result 241 } else { 242 # Withdraw on anything but 'break' return code 243 $self withdraw $result 244 } 245 return -code $code $result 246 } 247 248 method withdraw {{reason "withdraw"}} { 249 set result $reason 250 catch {grab release $win} 251 # Let's avoid focus/grab restore if we don't think we were showing 252 if {![winfo ismapped $win]} { return $reason } 253 wm withdraw $win 254 foreach {oldFocus oldGrab oldStatus} $lastFocusGrab { break } 255 # Ensure last focus/grab wasn't a child of this window 256 if {[winfo exists $oldFocus] && ![string match $win* $oldFocus]} { 257 catch {focus $oldFocus} 258 } 259 if {[winfo exists $oldGrab] && ![string match $win* $oldGrab]} { 260 if {$oldStatus eq "global"} { 261 catch {grab -global $oldGrab} 262 } elseif {$oldStatus eq "local"} { 263 catch {grab $oldGrab} 264 } 265 } 266 return $result 267 } 268 269 # ### ######### ########################### 270 ## Internal. State variable for close-button (X) 271 272 variable lastFocusGrab {}; 273 variable isPlaced 0; 274 variable result {}; 275 variable setwidget {}; 276 277 # ### ######### ########################### 278 ## Internal. Handle changes to the options. 279 280 method C-title {option value} { 281 wm title $win $value 282 wm iconname $win $value 283 set options($option) $value 284 } 285 method C-modal {option value} { 286 set values [list none local global] 287 if {[lsearch -exact $values $value] == -1} { 288 return -code error "unknown $option option \"$value\":\ 289 must be one of [join $values {, }]" 290 } 291 set options($option) $value 292 } 293 method C-separator {option value} { 294 if {$value} { 295 grid $separator 296 } else { 297 grid remove $separator 298 } 299 set options($option) $value 300 } 301 method C-parent {option value} { 302 if {$options(-transient) && [winfo exists $value]} { 303 wm transient $win [winfo toplevel $value] 304 wm group $win [winfo toplevel $value] 305 } else { 306 wm transient $win "" 307 wm group $win "" 308 } 309 set options($option) $value 310 } 311 method C-transient {option value} { 312 if {$value && [winfo exists $options(-parent)]} { 313 wm transient $win [winfo toplevel $options(-parent)] 314 wm group $win [winfo toplevel $options(-parent)] 315 } else { 316 wm transient $win "" 317 wm group $win "" 318 } 319 set options($option) $value 320 } 321 method C-place {option value} { 322 set values [list none center left right over above below pointer] 323 if {[lsearch -exact $values $value] == -1} { 324 return -code error "unknown $option option \"$value\":\ 325 must be one of [join $values {, }]" 326 } 327 set isPlaced 0 328 set options($option) $value 329 } 330 method C-type {option value} { 331 set types [list ok okcancel okcancelapply custom] 332 # ok 333 # okcancel 334 # okcancelapply 335 # custom 336 # msgcat 337 338 if {$options(-type) eq $value} { return } 339 if {[lsearch -exact $types $value] == -1} { 340 return -code error "invalid type \"$value\", must be one of:\ 341 [join $types {, }]" 342 } 343 if {$options(-type) ne "custom"} { 344 # Just trash whatever we had 345 eval [list destroy] [winfo children $buttonbox] 346 } 347 348 set ok [msgcat::mc "OK"] 349 set cancel [msgcat::mc "Cancel"] 350 set apply [msgcat::mc "Apply"] 351 set okBtn [ttk::button $buttonbox.ok -text $ok -default active \ 352 -command [mymethod close ok]] 353 set canBtn [ttk::button $buttonbox.cancel -text $cancel \ 354 -command [mymethod close cancel]] 355 set appBtn [ttk::button $buttonbox.apply -text $apply \ 356 -command [mymethod close apply]] 357 358 # [OK] [Cancel] [Apply] 359 grid x $okBtn $canBtn $appBtn -padx 4 360 grid columnconfigure $buttonbox 0 -weight 1 361 #bind $win <Return> [list $okBtn invoke] 362 #bind $win <Escape> [list $canBtn invoke] 363 if {$value eq "ok"} { 364 grid remove $canBtn $appBtn 365 } elseif {$value eq "okcancel"} { 366 grid remove $appBtn 367 } 368 set options($option) $value 369 } 370 371 # ### ######### ########################### 372 ## Internal. 373 374 method PlaceWindow {w place anchor} { 375 # Variation of tk::PlaceWindow 376 if {$isPlaced || $place eq "none"} { 377 # For most options, we place once and then just deiconify 378 wm deiconify $w 379 raise $w 380 return 381 } 382 set isPlaced 1 383 if {$place eq "pointer"} { 384 # pointer placement occurs each time, centered 385 set anchor center 386 set isPlaced 0 387 } elseif {![winfo exists $anchor]} { 388 set anchor [winfo toplevel [winfo parent $w]] 389 if {![winfo ismapped $anchor]} { 390 set place center 391 } 392 } 393 wm withdraw $w 394 update idletasks 395 set checkBounds 1 396 if {$place eq "center"} { 397 set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}] 398 set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}] 399 set checkBounds 0 400 } elseif {$place eq "pointer"} { 401 ## place at POINTER (centered) 402 if {$anchor eq "center"} { 403 set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}] 404 set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}] 405 } else { 406 set x [winfo pointerx $w] 407 set y [winfo pointery $w] 408 } 409 } elseif {![winfo ismapped $anchor]} { 410 ## All the rest require the anchor to be mapped 411 ## If the anchor isn't mapped, use center 412 set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}] 413 set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}] 414 set checkBounds 0 415 } elseif {$place eq "over"} { 416 ## center about WIDGET $anchor 417 set x [expr {[winfo rootx $anchor] + \ 418 ([winfo width $anchor]-[winfo reqwidth $w])/2}] 419 set y [expr {[winfo rooty $anchor] + \ 420 ([winfo height $anchor]-[winfo reqheight $w])/2}] 421 } elseif {$place eq "above"} { 422 ## above (north of) WIDGET $anchor, centered 423 set x [expr {[winfo rootx $anchor] + \ 424 ([winfo width $anchor]-[winfo reqwidth $w])/2}] 425 set y [expr {[winfo rooty $anchor] - [winfo reqheight $w]}] 426 } elseif {$place eq "below"} { 427 ## below WIDGET $anchor, centered 428 set x [expr {[winfo rootx $anchor] + \ 429 ([winfo width $anchor]-[winfo reqwidth $w])/2}] 430 set y [expr {[winfo rooty $anchor] + [winfo height $anchor]}] 431 } elseif {$place eq "left"} { 432 ## left of WIDGET $anchor, top-aligned 433 set x [expr {[winfo rootx $anchor] - [winfo reqwidth $w]}] 434 set y [winfo rooty $anchor] 435 } elseif {$place eq "right"} { 436 ## right of WIDGET $anchor, top-aligned 437 set x [expr {[winfo rootx $anchor] + [winfo width $anchor]}] 438 set y [winfo rooty $anchor] 439 } else { 440 return -code error "unknown place type \"$place\"" 441 } 442 if {[tk windowingsystem] eq "win32"} { 443 # win32 multiple desktops may produce negative geometry - avoid. 444 set checkBounds -1 445 } 446 if {$checkBounds} { 447 if {$x < 0 && $checkBounds > 0} { 448 set x 0 449 } elseif {$x > ([winfo screenwidth $w]-[winfo reqwidth $w])} { 450 set x [expr {[winfo screenwidth $w]-[winfo reqwidth $w]}] 451 } 452 if {$y < 0 && $checkBounds > 0} { 453 set y 0 454 } elseif {$y > ([winfo screenheight $w]-[winfo reqheight $w])} { 455 set y [expr {[winfo screenheight $w]-[winfo reqheight $w]}] 456 } 457 if {[tk windowingsystem] eq "aqua"} { 458 # Avoid the native menu bar which sits on top of everything. 459 if {$y < 20} { set y 20 } 460 } 461 } 462 wm geometry $w +$x+$y 463 wm deiconify $w 464 raise $w 465 } 466 467 # ### ######### ########################### 468} 469 470# ### ######### ########################### 471## Ready for use 472 473package provide widget::dialog 1.3.1 474