1# 2# $Id: dialog.tcl,v 1.6 2007/07/10 21:53:26 jenglish Exp $ 3# 4# Copyright (c) 2005, Joe English. Freely redistributable. 5# 6# Tile widget set: dialog boxes. 7# 8# TODO: option to keep dialog onscreen ("persistent" / "transient") 9# TODO: accelerator keys. 10# TODO: use message catalogs for button labels 11# TODO: routines to selectively enable/disable individual command buttons 12# TODO: use megawidgetoid API [$dlg dismiss] vs. [ttk::dialog::dismiss $dlg] 13# TODO: MAYBE: option for app-modal dialogs 14# TODO: MAYBE: [wm withdraw] dialog on dismiss instead of self-destructing 15# 16 17package provide ttk::dialog 0.8 18package require msgcat 19package require keynav 20 21namespace eval ttk::dialog { 22 23 variable Config 24 # 25 # Spacing parameters: 26 # (taken from GNOME HIG 2.0, may need adjustment for other platforms) 27 # (textwidth just a guess) 28 # 29 set Config(margin) 12 ;# space between icon and text 30 set Config(interspace) 6 ;# horizontal space between buttons 31 set Config(sepspace) 24 ;# vertical space above buttons 32 set Config(textwidth) 400 ;# width of dialog box text (pixels) 33 34 variable DialogTypes ;# map -type => list of dialog options 35 variable ButtonOptions ;# map button name => list of button options 36 37 # stockButton -- define new built-in button 38 # 39 proc stockButton {button args} { 40 variable ButtonOptions 41 set ButtonOptions($button) $args 42 } 43 44 # Built-in button types: 45 # 46 foreach button {OK Cancel Yes No Retry} { 47 set text [namespace eval ::tk "msgcat::mc &$button"] 48 set index [string first & $text] 49 regsub {&} $text {} text 50 stockButton [string tolower $button] -underline $index \ 51 -text $text 52 } 53 54 # stockDialog -- define new dialog type. 55 # 56 proc stockDialog {type args} { 57 variable DialogTypes 58 set DialogTypes($type) $args 59 } 60 61 # Built-in dialog types: 62 # 63 stockDialog ok \ 64 -icon info -buttons {ok} -default ok 65 stockDialog okcancel \ 66 -icon info -buttons {ok cancel} -default ok -cancel cancel 67 stockDialog retrycancel \ 68 -icon question -buttons {retry cancel} -cancel cancel 69 stockDialog yesno \ 70 -icon question -buttons {yes no} 71 stockDialog yesnocancel \ 72 -icon question -buttons {yes no cancel} -cancel cancel 73} 74 75## ttk::dialog::nop -- 76# Do nothing (used as a default callback command). 77# 78proc ttk::dialog::nop {args} { } 79 80## ttk::dialog -- dialog box constructor. 81# 82interp alias {} ttk::dialog {} ttk::dialog::Constructor 83 84proc ttk::dialog::Constructor {dlg args} { 85 upvar #0 $dlg D 86 variable Config 87 variable ButtonOptions 88 variable DialogTypes 89 90 # 91 # Option processing: 92 # 93 array set defaults { 94 -title "" 95 -message "" 96 -detail "" 97 -command ttk::dialog::nop 98 -icon "" 99 -buttons {} 100 -labels {} 101 -default {} 102 -cancel {} 103 -parent #AUTO 104 } 105 106 array set options [array get defaults] 107 108 foreach {option value} $args { 109 if {$option eq "-type"} { 110 array set options $DialogTypes($value) 111 } elseif {![info exists options($option)]} { 112 set validOptions [join [lsort [array names options]] ", "] 113 return -code error \ 114 "Illegal option $option: must be one of $validOptions" 115 } 116 } 117 array set options $args 118 119 # ... 120 # 121 array set buttonOptions [array get ::ttk::dialog::ButtonOptions] 122 foreach {button label} $options(-labels) { 123 lappend buttonOptions($button) -text $label 124 } 125 126 # 127 # Initialize dialog private data: 128 # 129 foreach option {-command -message -detail} { 130 set D($option) $options($option) 131 } 132 133 toplevel $dlg -class Dialog; wm withdraw $dlg 134 135 # 136 # Determine default transient parent. 137 # 138 # NB: menus (including menubars) are considered toplevels, 139 # so skip over those. 140 # 141 if {$options(-parent) eq "#AUTO"} { 142 set parent [winfo toplevel [winfo parent $dlg]] 143 while {[winfo class $parent] eq "Menu" && $parent ne "."} { 144 set parent [winfo toplevel [winfo parent $parent]] 145 } 146 set options(-parent) $parent 147 } 148 149 # 150 # Build dialog: 151 # 152 if {$options(-parent) ne ""} { 153 wm transient $dlg $options(-parent) 154 } 155 wm title $dlg $options(-title) 156 wm protocol $dlg WM_DELETE_WINDOW { } 157 158 set f [ttk::frame $dlg.f] 159 160 ttk::label $f.icon 161 if {$options(-icon) ne ""} { 162 $f.icon configure -image [ttk::stockIcon dialog/$options(-icon)] 163 } 164 ttk::label $f.message -textvariable ${dlg}(-message) \ 165 -font TkCaptionFont -wraplength $Config(textwidth)\ 166 -anchor w -justify left 167 ttk::label $f.detail -textvariable ${dlg}(-detail) \ 168 -font TkTextFont -wraplength $Config(textwidth) \ 169 -anchor w -justify left 170 171 # 172 # Command buttons: 173 # 174 set cmd [ttk::frame $f.cmd] 175 set column 0 176 grid columnconfigure $f.cmd 0 -weight 1 177 178 foreach button $options(-buttons) { 179 incr column 180 eval [linsert $buttonOptions($button) 0 ttk::button $cmd.$button] 181 $cmd.$button configure -command [list ttk::dialog::Done $dlg $button] 182 grid $cmd.$button -row 0 -column $column \ 183 -padx [list $Config(interspace) 0] -sticky ew 184 grid columnconfigure $cmd $column -uniform buttons 185 } 186 187 if {$options(-default) ne ""} { 188 keynav::defaultButton $cmd.$options(-default) 189 focus $cmd.$options(-default) 190 } 191 if {$options(-cancel) ne ""} { 192 bind $dlg <KeyPress-Escape> \ 193 [list event generate $cmd.$options(-cancel) <<Invoke>>] 194 wm protocol $dlg WM_DELETE_WINDOW \ 195 [list event generate $cmd.$options(-cancel) <<Invoke>>] 196 } 197 198 # 199 # Assemble dialog. 200 # 201 pack $f.cmd -side bottom -expand false -fill x \ 202 -pady [list $Config(sepspace) $Config(margin)] -padx $Config(margin) 203 204 if {0} { 205 # GNOME and Apple HIGs say not to use separators. 206 # But in case we want them anyway: 207 # 208 pack [ttk::separator $f.sep -orient horizontal] \ 209 -side bottom -expand false -fill x \ 210 -pady [list $Config(sepspace) 0] \ 211 -padx $Config(margin) 212 } 213 214 if {$options(-icon) ne ""} { 215 pack $f.icon -side left -anchor n -expand false \ 216 -pady $Config(margin) -padx $Config(margin) 217 } 218 219 pack $f.message -side top -expand false -fill x \ 220 -padx $Config(margin) -pady $Config(margin) 221 if {$options(-detail) != ""} { 222 pack $f.detail -side top -expand false -fill x \ 223 -padx $Config(margin) 224 } 225 226 # Client area goes here. 227 228 pack $f -expand true -fill both 229 keynav::enableMnemonics $dlg 230 wm deiconify $dlg 231} 232 233## ttk::dialog::clientframe -- 234# Returns the widget path of the dialog client frame, 235# creating and managing it if necessary. 236# 237proc ttk::dialog::clientframe {dlg} { 238 variable Config 239 set client $dlg.f.client 240 if {![winfo exists $client]} { 241 pack [ttk::frame $client] -side top -expand true -fill both \ 242 -pady $Config(margin) -padx $Config(margin) 243 lower $client ;# so it's first in keyboard traversal order 244 } 245 return $client 246} 247 248## ttk::dialog::Done -- 249# -command callback for dialog command buttons (internal) 250# 251proc ttk::dialog::Done {dlg button} { 252 upvar #0 $dlg D 253 set rc [catch [linsert $D(-command) end $button] result] 254 if {$rc == 1} { 255 return -code $rc -errorinfo $::errorInfo -errorcode $::errorCode $result 256 } elseif {$rc == 3 || $rc == 4} { 257 # break or continue -- don't dismiss dialog 258 return 259 } 260 dismiss $dlg 261} 262 263## ttk::dialog::activate $dlg $button -- 264# Simulate a button press. 265# 266proc ttk::dialog::activate {dlg button} { 267 event generate $dlg.f.cmd.$button <<Invoke>> 268} 269 270## dismiss -- 271# Dismiss the dialog (without invoking any actions). 272# 273proc ttk::dialog::dismiss {dlg} { 274 uplevel #0 [list unset $dlg] 275 destroy $dlg 276} 277 278#*EOF* 279