fontchooser.tcl (15840B)
1 # fontchooser.tcl - 2 # 3 # A themeable Tk font selection dialog. See TIP #324. 4 # 5 # Copyright (C) 2008 Keith Vetter 6 # Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net> 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 namespace eval ::tk::fontchooser { 12 variable S 13 14 set S(W) .__tk__fontchooser 15 set S(fonts) [lsort -dictionary [font families]] 16 set S(styles) [list \ 17 [::msgcat::mc "Regular"] \ 18 [::msgcat::mc "Italic"] \ 19 [::msgcat::mc "Bold"] \ 20 [::msgcat::mc "Bold Italic"] \ 21 ] 22 23 set S(sizes) {8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72} 24 set S(strike) 0 25 set S(under) 0 26 set S(first) 1 27 set S(sampletext) [::msgcat::mc "AaBbYyZz01"] 28 set S(-parent) . 29 set S(-title) [::msgcat::mc "Font"] 30 set S(-command) "" 31 set S(-font) TkDefaultFont 32 } 33 34 proc ::tk::fontchooser::Setup {} { 35 variable S 36 37 # Canonical versions of font families, styles, etc. for easier searching 38 set S(fonts,lcase) {} 39 foreach font $S(fonts) { lappend S(fonts,lcase) [string tolower $font]} 40 set S(styles,lcase) {} 41 foreach style $S(styles) { lappend S(styles,lcase) [string tolower $style]} 42 set S(sizes,lcase) $S(sizes) 43 44 ::ttk::style layout FontchooserFrame { 45 Entry.field -sticky news -border true -children { 46 FontchooserFrame.padding -sticky news 47 } 48 } 49 bind [winfo class .] <<ThemeChanged>> \ 50 [list +ttk::style layout FontchooserFrame \ 51 [ttk::style layout FontchooserFrame]] 52 53 namespace ensemble create -map { 54 show ::tk::fontchooser::Show 55 hide ::tk::fontchooser::Hide 56 configure ::tk::fontchooser::Configure 57 } 58 } 59 ::tk::fontchooser::Setup 60 61 proc ::tk::fontchooser::Show {} { 62 variable S 63 if {![winfo exists $S(W)]} { 64 Create 65 wm transient $S(W) [winfo toplevel $S(-parent)] 66 tk::PlaceWindow $S(W) widget $S(-parent) 67 } 68 set S(fonts) [lsort -dictionary [font families]] 69 set S(fonts,lcase) {} 70 foreach font $S(fonts) { lappend S(fonts,lcase) [string tolower $font]} 71 wm deiconify $S(W) 72 } 73 74 proc ::tk::fontchooser::Hide {} { 75 variable S 76 wm withdraw $S(W) 77 } 78 79 proc ::tk::fontchooser::Configure {args} { 80 variable S 81 82 set specs { 83 {-parent "" "" . } 84 {-title "" "" ""} 85 {-font "" "" ""} 86 {-command "" "" ""} 87 } 88 89 if {[llength $args] == 0} { 90 set result {} 91 foreach spec $specs { 92 foreach {name xx yy default} $spec break 93 lappend result $name \ 94 [expr {[info exists S($name)] ? $S($name) : $default}] 95 } 96 lappend result -visible \ 97 [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}] 98 return $result 99 } 100 if {[llength $args] == 1} { 101 set option [lindex $args 0] 102 if {[string equal $option "-visible"]} { 103 return [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}] 104 } elseif {[info exists S($option)]} { 105 return $S($option) 106 } 107 return -code error -errorcode [list TK LOOKUP OPTION $option] \ 108 "bad option \"$option\": must be\ 109 -command, -font, -parent, -title or -visible" 110 } 111 112 set cache [dict create -parent $S(-parent) -title $S(-title) \ 113 -font $S(-font) -command $S(-command)] 114 set r [tclParseConfigSpec [namespace which -variable S] $specs "" $args] 115 if {![winfo exists $S(-parent)]} { 116 set code [list TK LOOKUP WINDOW $S(-parent)] 117 set err "bad window path name \"$S(-parent)\"" 118 array set S $cache 119 return -code error -errorcode $code $err 120 } 121 if {[string trim $S(-title)] eq ""} { 122 set S(-title) [::msgcat::mc "Font"] 123 } 124 if {[winfo exists $S(W)] && [lsearch $args -font] != -1} { 125 Init $S(-font) 126 event generate $S(-parent) <<TkFontchooserFontChanged>> 127 } 128 return $r 129 } 130 131 proc ::tk::fontchooser::Create {} { 132 variable S 133 set windowName __tk__fontchooser 134 if {$S(-parent) eq "."} { 135 set S(W) .$windowName 136 } else { 137 set S(W) $S(-parent).$windowName 138 } 139 140 # Now build the dialog 141 if {![winfo exists $S(W)]} { 142 toplevel $S(W) -class TkFontDialog 143 if {[package provide tcltest] ne {}} {set ::tk_dialog $S(W)} 144 wm withdraw $S(W) 145 wm title $S(W) $S(-title) 146 wm transient $S(W) [winfo toplevel $S(-parent)] 147 148 set outer [::ttk::frame $S(W).outer -padding {10 10}] 149 ::tk::AmpWidget ::ttk::label $S(W).font -text [::msgcat::mc "&Font:"] 150 ::tk::AmpWidget ::ttk::label $S(W).style -text [::msgcat::mc "Font st&yle:"] 151 ::tk::AmpWidget ::ttk::label $S(W).size -text [::msgcat::mc "&Size:"] 152 ttk::entry $S(W).efont -width 18 \ 153 -textvariable [namespace which -variable S](font) 154 ttk::entry $S(W).estyle -width 10 \ 155 -textvariable [namespace which -variable S](style) 156 ttk::entry $S(W).esize -textvariable [namespace which -variable S](size) \ 157 -width 3 -validate key -validatecommand {string is double %P} 158 159 ttk_slistbox $S(W).lfonts -height 7 -exportselection 0 \ 160 -selectmode browse -activestyle none \ 161 -listvariable [namespace which -variable S](fonts) 162 ttk_slistbox $S(W).lstyles -width 5 -height 7 -exportselection 0 \ 163 -selectmode browse -activestyle none \ 164 -listvariable [namespace which -variable S](styles) 165 ttk_slistbox $S(W).lsizes -width 4 -height 7 -exportselection 0 \ 166 -selectmode browse -activestyle none \ 167 -listvariable [namespace which -variable S](sizes) 168 169 set WE $S(W).effects 170 ::ttk::labelframe $WE -text [::msgcat::mc "Effects"] 171 ::tk::AmpWidget ::ttk::checkbutton $WE.strike \ 172 -variable [namespace which -variable S](strike) \ 173 -text [::msgcat::mc "Stri&keout"] \ 174 -command [namespace code [list Click strike]] 175 ::tk::AmpWidget ::ttk::checkbutton $WE.under \ 176 -variable [namespace which -variable S](under) \ 177 -text [::msgcat::mc "&Underline"] \ 178 -command [namespace code [list Click under]] 179 180 set bbox [::ttk::frame $S(W).bbox] 181 ::ttk::button $S(W).ok -text [::msgcat::mc OK] -default active\ 182 -command [namespace code [list Done 1]] 183 ::ttk::button $S(W).cancel -text [::msgcat::mc Cancel] \ 184 -command [namespace code [list Done 0]] 185 ::tk::AmpWidget ::ttk::button $S(W).apply -text [::msgcat::mc "&Apply"] \ 186 -command [namespace code [list Apply]] 187 wm protocol $S(W) WM_DELETE_WINDOW [namespace code [list Done 0]] 188 189 # Calculate minimum sizes 190 ttk::scrollbar $S(W).tmpvs 191 set scroll_width [winfo reqwidth $S(W).tmpvs] 192 destroy $S(W).tmpvs 193 set minsize(gap) 10 194 set minsize(bbox) [winfo reqwidth $S(W).ok] 195 set minsize(fonts) \ 196 [expr {[font measure TkDefaultFont "Helvetica"] + $scroll_width}] 197 set minsize(styles) \ 198 [expr {[font measure TkDefaultFont "Bold Italic"] + $scroll_width}] 199 set minsize(sizes) \ 200 [expr {[font measure TkDefaultFont "-99"] + $scroll_width}] 201 set min [expr {$minsize(gap) * 4}] 202 foreach {what width} [array get minsize] { incr min $width } 203 wm minsize $S(W) $min 260 204 205 bind $S(W) <Return> [namespace code [list Done 1]] 206 bind $S(W) <Escape> [namespace code [list Done 0]] 207 bind $S(W) <Map> [namespace code [list Visibility %W 1]] 208 bind $S(W) <Unmap> [namespace code [list Visibility %W 0]] 209 bind $S(W) <Destroy> [namespace code [list Visibility %W 0]] 210 bind $S(W).lfonts.list <<ListboxSelect>> [namespace code [list Click font]] 211 bind $S(W).lstyles.list <<ListboxSelect>> [namespace code [list Click style]] 212 bind $S(W).lsizes.list <<ListboxSelect>> [namespace code [list Click size]] 213 bind $S(W) <Alt-Key> [list ::tk::AltKeyInDialog $S(W) %A] 214 bind $S(W).font <<AltUnderlined>> [list ::focus $S(W).efont] 215 bind $S(W).style <<AltUnderlined>> [list ::focus $S(W).estyle] 216 bind $S(W).size <<AltUnderlined>> [list ::focus $S(W).esize] 217 bind $S(W).apply <<AltUnderlined>> [namespace code [list Apply]] 218 bind $WE.strike <<AltUnderlined>> [list $WE.strike invoke] 219 bind $WE.under <<AltUnderlined>> [list $WE.under invoke] 220 221 set WS $S(W).sample 222 ::ttk::labelframe $WS -text [::msgcat::mc "Sample"] 223 ::ttk::label $WS.sample -relief sunken -anchor center \ 224 -textvariable [namespace which -variable S](sampletext) 225 set S(sample) $WS.sample 226 grid $WS.sample -sticky news -padx 6 -pady 4 227 grid rowconfigure $WS 0 -weight 1 228 grid columnconfigure $WS 0 -weight 1 229 grid propagate $WS 0 230 231 grid $S(W).ok -in $bbox -sticky new -pady {0 2} 232 grid $S(W).cancel -in $bbox -sticky new -pady 2 233 if {$S(-command) ne ""} { 234 grid $S(W).apply -in $bbox -sticky new -pady 2 235 } 236 grid columnconfigure $bbox 0 -weight 1 237 238 grid $WE.strike -sticky w -padx 10 239 grid $WE.under -sticky w -padx 10 -pady {0 30} 240 grid columnconfigure $WE 1 -weight 1 241 242 grid $S(W).font x $S(W).style x $S(W).size x -in $outer -sticky w 243 grid $S(W).efont x $S(W).estyle x $S(W).esize x $bbox -in $outer -sticky ew 244 grid $S(W).lfonts x $S(W).lstyles x $S(W).lsizes x ^ -in $outer -sticky news 245 grid $WE x $WS - - x ^ -in $outer -sticky news -pady {15 30} 246 grid configure $bbox -sticky n 247 grid columnconfigure $outer {1 3 5} -minsize $minsize(gap) 248 grid columnconfigure $outer {0 2 4} -weight 1 249 grid columnconfigure $outer 0 -minsize $minsize(fonts) 250 grid columnconfigure $outer 2 -minsize $minsize(styles) 251 grid columnconfigure $outer 4 -minsize $minsize(sizes) 252 grid columnconfigure $outer 6 -minsize $minsize(bbox) 253 254 grid $outer -sticky news 255 grid rowconfigure $S(W) 0 -weight 1 256 grid columnconfigure $S(W) 0 -weight 1 257 258 Init $S(-font) 259 260 trace add variable [namespace which -variable S](size) \ 261 write [namespace code [list Tracer]] 262 trace add variable [namespace which -variable S](style) \ 263 write [namespace code [list Tracer]] 264 trace add variable [namespace which -variable S](font) \ 265 write [namespace code [list Tracer]] 266 } else { 267 Init $S(-font) 268 } 269 270 return 271 } 272 273 # ::tk::fontchooser::Done -- 274 # 275 # Handles teardown of the dialog, calling -command if needed 276 # 277 # Arguments: 278 # ok true if user pressed OK 279 # 280 proc ::tk::::fontchooser::Done {ok} { 281 variable S 282 283 if {! $ok} { 284 set S(result) "" 285 } 286 trace vdelete S(size) w [namespace code [list Tracer]] 287 trace vdelete S(style) w [namespace code [list Tracer]] 288 trace vdelete S(font) w [namespace code [list Tracer]] 289 destroy $S(W) 290 if {$ok && $S(-command) ne ""} { 291 uplevel #0 $S(-command) [list $S(result)] 292 } 293 } 294 295 # ::tk::fontchooser::Apply -- 296 # 297 # Call the -command procedure appending the current font 298 # Errors are reported via the background error mechanism 299 # 300 proc ::tk::fontchooser::Apply {} { 301 variable S 302 if {$S(-command) ne ""} { 303 if {[catch {uplevel #0 $S(-command) [list $S(result)]} err]} { 304 ::bgerror $err 305 } 306 } 307 event generate $S(-parent) <<TkFontchooserFontChanged>> 308 } 309 310 # ::tk::fontchooser::Init -- 311 # 312 # Initializes dialog to a default font 313 # 314 # Arguments: 315 # defaultFont font to use as the default 316 # 317 proc ::tk::fontchooser::Init {{defaultFont ""}} { 318 variable S 319 320 if {$S(first) || $defaultFont ne ""} { 321 if {$defaultFont eq ""} { 322 set defaultFont [[entry .___e] cget -font] 323 destroy .___e 324 } 325 array set F [font actual $defaultFont] 326 set S(font) $F(-family) 327 set S(size) $F(-size) 328 set S(strike) $F(-overstrike) 329 set S(under) $F(-underline) 330 set S(style) "Regular" 331 if {$F(-weight) eq "bold" && $F(-slant) eq "italic"} { 332 set S(style) "Bold Italic" 333 } elseif {$F(-weight) eq "bold"} { 334 set S(style) "Bold" 335 } elseif {$F(-slant) eq "italic"} { 336 set S(style) "Italic" 337 } 338 339 set S(first) 0 340 } 341 342 Tracer a b c 343 Update 344 } 345 346 # ::tk::fontchooser::Click -- 347 # 348 # Handles all button clicks, updating the appropriate widgets 349 # 350 # Arguments: 351 # who which widget got pressed 352 # 353 proc ::tk::fontchooser::Click {who} { 354 variable S 355 356 if {$who eq "font"} { 357 set S(font) [$S(W).lfonts get [$S(W).lfonts curselection]] 358 } elseif {$who eq "style"} { 359 set S(style) [$S(W).lstyles get [$S(W).lstyles curselection]] 360 } elseif {$who eq "size"} { 361 set S(size) [$S(W).lsizes get [$S(W).lsizes curselection]] 362 } 363 Update 364 } 365 366 # ::tk::fontchooser::Tracer -- 367 # 368 # Handles traces on key variables, updating the appropriate widgets 369 # 370 # Arguments: 371 # standard trace arguments (not used) 372 # 373 proc ::tk::fontchooser::Tracer {var1 var2 op} { 374 variable S 375 376 set bad 0 377 set nstate normal 378 # Make selection in each listbox 379 foreach var {font style size} { 380 set value [string tolower $S($var)] 381 $S(W).l${var}s selection clear 0 end 382 set n [lsearch -exact $S(${var}s,lcase) $value] 383 $S(W).l${var}s selection set $n 384 if {$n != -1} { 385 set S($var) [lindex $S(${var}s) $n] 386 $S(W).e$var icursor end 387 $S(W).e$var selection clear 388 } else { ;# No match, try prefix 389 # Size is weird: valid numbers are legal but don't display 390 # unless in the font size list 391 set n [lsearch -glob $S(${var}s,lcase) "$value*"] 392 set bad 1 393 if {$var ne "size" || ! [string is double -strict $value]} { 394 set nstate disabled 395 } 396 } 397 $S(W).l${var}s see $n 398 } 399 if {!$bad} { Update } 400 $S(W).ok configure -state $nstate 401 } 402 403 # ::tk::fontchooser::Update -- 404 # 405 # Shows a sample of the currently selected font 406 # 407 proc ::tk::fontchooser::Update {} { 408 variable S 409 410 set S(result) [list $S(font) $S(size)] 411 if {$S(style) eq "Bold"} { lappend S(result) bold } 412 if {$S(style) eq "Italic"} { lappend S(result) italic } 413 if {$S(style) eq "Bold Italic"} { lappend S(result) bold italic} 414 if {$S(strike)} { lappend S(result) overstrike} 415 if {$S(under)} { lappend S(result) underline} 416 417 $S(sample) configure -font $S(result) 418 } 419 420 # ::tk::fontchooser::Visibility -- 421 # 422 # Notify the parent when the dialog visibility changes 423 # 424 proc ::tk::fontchooser::Visibility {w visible} { 425 variable S 426 if {$w eq $S(W)} { 427 event generate $S(-parent) <<TkFontchooserVisibility>> 428 } 429 } 430 431 # ::tk::fontchooser::ttk_listbox -- 432 # 433 # Create a properly themed scrolled listbox. 434 # This is exactly right on XP but may need adjusting on other platforms. 435 # 436 proc ::tk::fontchooser::ttk_slistbox {w args} { 437 set f [ttk::frame $w -style FontchooserFrame -padding 2] 438 if {[catch { 439 listbox $f.list -relief flat -highlightthickness 0 -borderwidth 0 {*}$args 440 ttk::scrollbar $f.vs -command [list $f.list yview] 441 $f.list configure -yscrollcommand [list $f.vs set] 442 grid $f.list $f.vs -sticky news 443 grid rowconfigure $f 0 -weight 1 444 grid columnconfigure $f 0 -weight 1 445 interp hide {} $w 446 interp alias {} $w {} $f.list 447 } err opt]} { 448 destroy $f 449 return -options $opt $err 450 } 451 return $w 452 }