1# ---------------------------------------------------------------------------- 2# font.tcl 3# This file is part of Unifix BWidget Toolkit 4# ---------------------------------------------------------------------------- 5# Index of commands: 6# - SelectFont::create 7# - SelectFont::configure 8# - SelectFont::cget 9# - SelectFont::_draw 10# - SelectFont::_destroy 11# - SelectFont::_modstyle 12# - SelectFont::_update 13# - SelectFont::_getfont 14# - SelectFont::_init 15# ---------------------------------------------------------------------------- 16 17namespace eval SelectFont { 18 Dialog::use 19 LabelFrame::use 20 ScrolledWindow::use 21 22 Widget::declare SelectFont { 23 {-title String "Font selection" 0} 24 {-parent String "" 0} 25 {-background TkResource "" 0 frame} 26 27 {-type Enum dialog 0 {dialog toolbar}} 28 {-font TkResource "" 0 label} 29 {-families String "all" 1} 30 {-querysystem Boolean 1 0} 31 {-styles String "bold italic underline overstrike" 1} 32 {-command String "" 0} 33 {-sampletext String "Sample Text" 0} 34 {-bg Synonym -background} 35 } 36 37 proc ::SelectFont { path args } { 38 return [eval SelectFont::create $path $args] 39 } 40 proc use {} {} 41 42 variable _families 43 variable _styleOff 44 array set _styleOff [list bold normal italic roman] 45 variable _sizes {4 5 6 7 8 9 10 11 12 13 14 15 16 \ 46 17 18 19 20 21 22 23 24} 47 48 # Set up preset lists of fonts, so the user can avoid the painfully slow 49 # loadfont process if desired. 50 if { [string equal $::tcl_platform(platform) "windows"] } { 51 set presetVariable [list \ 52 7x14 \ 53 Arial \ 54 {Arial Narrow} \ 55 {Lucida Sans} \ 56 {MS Sans Serif} \ 57 {MS Serif} \ 58 {Times New Roman} \ 59 ] 60 set presetFixed [list \ 61 6x13 \ 62 {Courier New} \ 63 FixedSys \ 64 Terminal \ 65 ] 66 set presetAll [list \ 67 6x13 \ 68 7x14 \ 69 Arial \ 70 {Arial Narrow} \ 71 {Courier New} \ 72 FixedSys \ 73 {Lucida Sans} \ 74 {MS Sans Serif} \ 75 {MS Serif} \ 76 Terminal \ 77 {Times New Roman} \ 78 ] 79 } else { 80 set presetVariable [list \ 81 helvetica \ 82 lucida \ 83 lucidabright \ 84 {times new roman} \ 85 ] 86 set presetFixed [list \ 87 courier \ 88 fixed \ 89 {lucida typewriter} \ 90 screen \ 91 serif \ 92 terminal \ 93 ] 94 set presetAll [list \ 95 courier \ 96 fixed \ 97 helvetica \ 98 lucida \ 99 lucidabright \ 100 {lucida typewriter} \ 101 screen \ 102 serif \ 103 terminal \ 104 {times new roman} \ 105 ] 106 } 107 array set _families [list \ 108 presetvariable $presetVariable \ 109 presetfixed $presetFixed \ 110 presetall $presetAll \ 111 ] 112 113 variable _widget 114} 115 116 117# ---------------------------------------------------------------------------- 118# Command SelectFont::create 119# ---------------------------------------------------------------------------- 120proc SelectFont::create { path args } { 121 variable _families 122 variable _sizes 123 variable $path 124 upvar 0 $path data 125 126 # Initialize the internal rep of the widget options 127 Widget::init SelectFont "$path#SelectFont" $args 128 129 if { [Widget::getoption "$path#SelectFont" -querysystem] } { 130 loadfont [Widget::getoption "$path#SelectFont" -families] 131 } 132 133 set bg [Widget::getoption "$path#SelectFont" -background] 134 set _styles [Widget::getoption "$path#SelectFont" -styles] 135 if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } { 136 Dialog::create $path -modal local -default 0 -cancel 1 -background $bg \ 137 -title [Widget::getoption "$path#SelectFont" -title] \ 138 -parent [Widget::getoption "$path#SelectFont" -parent] 139 140 set frame [Dialog::getframe $path] 141 set topf [frame $frame.topf -relief flat -borderwidth 0 -background $bg] 142 143 set labf1 [LabelFrame::create $topf.labf1 -text "Font" -name font \ 144 -side top -anchor w -relief flat -background $bg] 145 set sw [ScrolledWindow::create [LabelFrame::getframe $labf1].sw \ 146 -background $bg] 147 set lbf [listbox $sw.lb \ 148 -height 5 -width 25 -exportselection false -selectmode browse] 149 ScrolledWindow::setwidget $sw $lbf 150 LabelFrame::configure $labf1 -focus $lbf 151 if { [Widget::getoption "$path#SelectFont" -querysystem] } { 152 set fam [Widget::getoption "$path#SelectFont" -families] 153 } else { 154 set fam "preset" 155 append fam [Widget::getoption "$path#SelectFont" -families] 156 } 157 eval [list $lbf insert end] $_families($fam) 158 set script "set SelectFont::$path\(family\) \[%W curselection\]; SelectFont::_update $path" 159 bind $lbf <ButtonRelease-1> $script 160 bind $lbf <space> $script 161 pack $sw -fill both -expand yes 162 163 set labf2 [LabelFrame::create $topf.labf2 -text "Size" -name size \ 164 -side top -anchor w -relief flat -background $bg] 165 set sw [ScrolledWindow::create [LabelFrame::getframe $labf2].sw \ 166 -scrollbar vertical -background $bg] 167 set lbs [listbox $sw.lb \ 168 -height 5 -width 6 -exportselection false -selectmode browse] 169 ScrolledWindow::setwidget $sw $lbs 170 LabelFrame::configure $labf2 -focus $lbs 171 eval [list $lbs insert end] $_sizes 172 set script "set SelectFont::$path\(size\) \[%W curselection\]; SelectFont::_update $path" 173 bind $lbs <ButtonRelease-1> $script 174 bind $lbs <space> $script 175 pack $sw -fill both -expand yes 176 177 set labf3 [LabelFrame::create $topf.labf3 -text "Style" -name style \ 178 -side top -anchor w -relief sunken -bd 1 -background $bg] 179 set subf [LabelFrame::getframe $labf3] 180 foreach st $_styles { 181 set name [lindex [BWidget::getname $st] 0] 182 if { $name == "" } { 183 set name "[string toupper [string index $name 0]][string range $name 1 end]" 184 } 185 checkbutton $subf.$st -text $name \ 186 -variable SelectFont::$path\($st\) \ 187 -background $bg \ 188 -command "SelectFont::_update $path" 189 bind $subf.$st <Return> break 190 pack $subf.$st -anchor w 191 } 192 LabelFrame::configure $labf3 -focus $subf.[lindex $_styles 0] 193 194 pack $labf1 -side left -anchor n -fill both -expand yes 195 pack $labf2 -side left -anchor n -fill both -expand yes -padx 8 196 pack $labf3 -side left -anchor n -fill both -expand yes 197 198 set botf [frame $frame.botf -width 100 -height 50 \ 199 -bg white -bd 0 -relief flat \ 200 -highlightthickness 1 -takefocus 0 \ 201 -highlightbackground black \ 202 -highlightcolor black] 203 204 set lab [label $botf.label \ 205 -background white -foreground black \ 206 -borderwidth 0 -takefocus 0 -highlightthickness 0 \ 207 -text [Widget::getoption "$path#SelectFont" -sampletext]] 208 place $lab -relx 0.5 -rely 0.5 -anchor c 209 210 pack $topf -pady 4 -fill both -expand yes 211 pack $botf -pady 4 -fill x 212 213 Dialog::add $path -name ok 214 Dialog::add $path -name cancel 215 216 set data(label) $lab 217 set data(lbf) $lbf 218 set data(lbs) $lbs 219 220 _getfont $path 221 222 proc ::$path { cmd args } "return \[eval SelectFont::\$cmd $path \$args\]" 223 224 return [_draw $path] 225 } else { 226 if { [Widget::getoption "$path#SelectFont" -querysystem] } { 227 set fams [Widget::getoption "$path#SelectFont" -families] 228 } else { 229 set fams "preset" 230 append fams [Widget::getoption "$path#SelectFont" -families] 231 } 232 frame $path -relief flat -borderwidth 0 -background $bg 233 bind $path <Destroy> "SelectFont::_destroy $path" 234 set lbf [ComboBox::create $path.font \ 235 -highlightthickness 0 -takefocus 0 -background $bg \ 236 -values $_families($fams) \ 237 -textvariable SelectFont::$path\(family\) \ 238 -editable 0 \ 239 -modifycmd "SelectFont::_update $path"] 240 set lbs [ComboBox::create $path.size \ 241 -highlightthickness 0 -takefocus 0 -background $bg \ 242 -width 4 \ 243 -values $_sizes \ 244 -textvariable SelectFont::$path\(size\) \ 245 -editable 0 \ 246 -modifycmd "SelectFont::_update $path"] 247 pack $lbf -side left -anchor w 248 pack $lbs -side left -anchor w -padx 4 249 foreach st $_styles { 250 button $path.$st \ 251 -highlightthickness 0 -takefocus 0 -padx 0 -pady 0 -bd 2 \ 252 -background $bg \ 253 -image [Bitmap::get $st] \ 254 -command "SelectFont::_modstyle $path $st" 255 pack $path.$st -side left -anchor w 256 } 257 set data(label) "" 258 set data(lbf) $lbf 259 set data(lbs) $lbs 260 _getfont $path 261 262 rename $path ::$path:cmd 263 proc ::$path { cmd args } "return \[eval SelectFont::\$cmd $path \$args\]" 264 } 265 266 return $path 267} 268 269 270# ---------------------------------------------------------------------------- 271# Command SelectFont::configure 272# ---------------------------------------------------------------------------- 273proc SelectFont::configure { path args } { 274 set _styles [Widget::getoption "$path#SelectFont" -styles] 275 276 set res [Widget::configure "$path#SelectFont" $args] 277 278 if { [Widget::hasChanged "$path#SelectFont" -font font] } { 279 _getfont $path 280 } 281 if { [Widget::hasChanged "$path#SelectFont" -background bg] } { 282 switch -- [Widget::getoption "$path#SelectFont" -type] { 283 dialog { 284 Dialog::configure $path -background $bg 285 set topf [Dialog::getframe $path].topf 286 $topf configure -background $bg 287 foreach labf {labf1 labf2} { 288 LabelFrame::configure $topf.$labf -background $bg 289 set subf [LabelFrame::getframe $topf.$labf] 290 ScrolledWindow::configure $subf.sw -background $bg 291 $subf.sw.lb configure -background $bg 292 } 293 LabelFrame::configure $topf.labf3 -background $bg 294 set subf [LabelFrame::getframe $topf.labf3] 295 foreach w [winfo children $subf] { 296 $w configure -background $bg 297 } 298 } 299 toolbar { 300 $path configure -background $bg 301 ComboBox::configure $path.font -background $bg 302 ComboBox::configure $path.size -background $bg 303 foreach st $_styles { 304 $path.$st configure -background $bg 305 } 306 } 307 } 308 } 309 return $res 310} 311 312 313# ---------------------------------------------------------------------------- 314# Command SelectFont::cget 315# ---------------------------------------------------------------------------- 316proc SelectFont::cget { path option } { 317 return [Widget::cget "$path#SelectFont" $option] 318} 319 320 321# ---------------------------------------------------------------------------- 322# Command SelectFont::loadfont 323# ---------------------------------------------------------------------------- 324proc SelectFont::loadfont {{which all}} { 325 variable _families 326 327 # initialize families 328 if {![info exists _families(all)]} { 329 set _families(all) [lsort -dictionary [font families]] 330 } 331 if {[regexp {fixed|variable} $which] \ 332 && ![info exists _families($which)]} { 333 # initialize families 334 set _families(fixed) {} 335 set _families(variable) {} 336 foreach family $_families(all) { 337 if { [font metrics [list $family] -fixed] } { 338 lappend _families(fixed) $family 339 } else { 340 lappend _families(variable) $family 341 } 342 } 343 } 344 return 345} 346 347 348# ---------------------------------------------------------------------------- 349# Command SelectFont::_draw 350# ---------------------------------------------------------------------------- 351proc SelectFont::_draw { path } { 352 variable $path 353 upvar 0 $path data 354 355 $data(lbf) selection clear 0 end 356 $data(lbf) selection set $data(family) 357 $data(lbf) activate $data(family) 358 $data(lbf) see $data(family) 359 $data(lbs) selection clear 0 end 360 $data(lbs) selection set $data(size) 361 $data(lbs) activate $data(size) 362 $data(lbs) see $data(size) 363 _update $path 364 365 if { [Dialog::draw $path] == 0 } { 366 set result [Widget::getoption "$path#SelectFont" -font] 367 } else { 368 set result "" 369 } 370 unset data 371 Widget::destroy "$path#SelectFont" 372 destroy $path 373 return $result 374} 375 376 377# ---------------------------------------------------------------------------- 378# Command SelectFont::_destroy 379# ---------------------------------------------------------------------------- 380proc SelectFont::_destroy { path } { 381 variable $path 382 upvar 0 $path data 383 384 unset data 385 Widget::destroy "$path#SelectFont" 386 rename $path {} 387} 388 389 390# ---------------------------------------------------------------------------- 391# Command SelectFont::_modstyle 392# ---------------------------------------------------------------------------- 393proc SelectFont::_modstyle { path style } { 394 variable $path 395 upvar 0 $path data 396 397 if { $data($style) == 1 } { 398 $path.$style configure -relief raised 399 set data($style) 0 400 } else { 401 $path.$style configure -relief sunken 402 set data($style) 1 403 } 404 _update $path 405} 406 407 408# ---------------------------------------------------------------------------- 409# Command SelectFont::_update 410# ---------------------------------------------------------------------------- 411proc SelectFont::_update { path } { 412 variable _families 413 variable _sizes 414 variable _styleOff 415 variable $path 416 upvar 0 $path data 417 418 set type [Widget::getoption "$path#SelectFont" -type] 419 set _styles [Widget::getoption "$path#SelectFont" -styles] 420 if { [Widget::getoption "$path#SelectFont" -querysystem] } { 421 set fams [Widget::getoption "$path#SelectFont" -families] 422 } else { 423 set fams "preset" 424 append fams [Widget::getoption "$path#SelectFont" -families] 425 } 426 if { $type == "dialog" } { 427 set curs [$path:cmd cget -cursor] 428 $path:cmd configure -cursor watch 429 } 430 if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } { 431 set font [list [lindex $_families($fams) $data(family)] \ 432 [lindex $_sizes $data(size)]] 433 } else { 434 set font [list $data(family) $data(size)] 435 } 436 foreach st $_styles { 437 if { $data($st) } { 438 lappend font $st 439 } elseif {[info exists _styleOff($st)]} { 440 # This adds the default bold/italic value to a font 441 #lappend font $_styleOff($st) 442 } 443 } 444 Widget::setoption "$path#SelectFont" -font $font 445 if { $type == "dialog" } { 446 $data(label) configure -font $font 447 $path:cmd configure -cursor $curs 448 } elseif { [set cmd [Widget::getoption "$path#SelectFont" -command]] != "" } { 449 uplevel \#0 $cmd 450 } 451} 452 453 454# ---------------------------------------------------------------------------- 455# Command SelectFont::_getfont 456# ---------------------------------------------------------------------------- 457proc SelectFont::_getfont { path } { 458 variable _families 459 variable _sizes 460 variable $path 461 upvar 0 $path data 462 463 array set font [font actual [Widget::getoption "$path#SelectFont" -font]] 464 set data(bold) [expr {![string equal $font(-weight) "normal"]}] 465 set data(italic) [expr {![string equal $font(-slant) "roman"]}] 466 set data(underline) $font(-underline) 467 set data(overstrike) $font(-overstrike) 468 set _styles [Widget::getoption "$path#SelectFont" -styles] 469 if { [Widget::getoption "$path#SelectFont" -querysystem] } { 470 set fams [Widget::getoption "$path#SelectFont" -families] 471 } else { 472 set fams "preset" 473 append fams [Widget::getoption "$path#SelectFont" -families] 474 } 475 if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } { 476 set idxf [lsearch $_families($fams) $font(-family)] 477 set idxs [lsearch $_sizes $font(-size)] 478 set data(family) [expr {$idxf >= 0 ? $idxf : 0}] 479 set data(size) [expr {$idxs >= 0 ? $idxs : 0}] 480 } else { 481 set data(family) $font(-family) 482 set data(size) $font(-size) 483 foreach st $_styles { 484 $path.$st configure -relief [expr {$data($st) ? "sunken":"raised"}] 485 } 486 } 487} 488 489