Bwidget Source Code
Check-in [3e02826d52]
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:* font.tcl: Added one new flag: -querysystem. This lets the user control whether the font selector queries the system (via font families) for the list of fonts, or if it uses a preset list of fonts (which is much faster and less likely to crash some systems).
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 3e02826d52491e66340b6e81f2a4b6858a572ae3
User & Date: ericm 1999-10-29 19:00:16
Context
1999-10-29
21:00
Fixed font lists on windows. check-in: e33b90fb7b user: ericm tags: trunk
19:00
* font.tcl: Added one new flag: -querysystem. This lets the user control whether the font selector queries the system (via font families) for the list of fonts, or if it uses a preset list of fonts (which is much faster and less likely to crash some systems). check-in: 3e02826d52 user: ericm tags: trunk
1999-10-25
23:00
Fixed some issues with the new -style flag. check-in: 3d735e7800 user: ericm tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.








1
2
3
4
5
6
7






1999-10-25  Eric Melski  <[email protected]>

	* font.tcl: Added support for two new flags: -families and -styles; 
	-families allows you to specify one of all, fixed, or variable, to limit 
	the choice of fonts to those fonts; -styles allows you to specify a list
	of styles that can be set with the widget (ie, bold, italic, etc).

>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
1999-10-29  Eric Melski  <[email protected]>

	* font.tcl: Added one new flag: -querysystem.  This lets the user 
	control whether the font selector queries the system (via font families)
	for the list of fonts, or if it uses a preset list of fonts (which is
	much faster and less likely to crash some systems).

1999-10-25  Eric Melski  <[email protected]>

	* font.tcl: Added support for two new flags: -families and -styles; 
	-families allows you to specify one of all, fixed, or variable, to limit 
	the choice of fonts to those fonts; -styles allows you to specify a list
	of styles that can be set with the widget (ie, bold, italic, etc).

Changes to font.tcl.

16
17
18
19
20
21
22
23
24
25
26
27
28
29

30
31
32
33

34
35

36

37
38
39
40
41
42

43

































































44
45
46
47
48
49
50
51
52
53
54
55
56
57



58

59
60
61

62
63
64
65
66
67
68
..
73
74
75
76
77
78
79
80
81





82
83
84
85
86
87
88
...
143
144
145
146
147
148
149

150




151
152
153
154
155
156
157
...
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
...
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
...
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
...
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
...
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341


342


343

344
345
346
347
348
349
350
...
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389

390




391
392
393
394
395
396
397
namespace eval SelectFont {
    Dialog::use
    LabelFrame::use
    ScrolledWindow::use

    Widget::declare SelectFont {
        {-title      String     "Font selection" 0}
        {-parent     String     "" 0}
        {-background TkResource "" 0 frame}

        {-type       Enum       dialog        0 {dialog toolbar}}
        {-font       TkResource ""            0 label}
	{-families   String     "all"         1}

	{-styles     String     "bold italic underline overstrike" 1}
        {-command    String     ""            0}
        {-sampletext String     "Sample Text" 0}
        {-bg         Synonym    -background}

    }


    proc ::SelectFont { path args } { return [eval SelectFont::create $path $args] }

    proc use {} {}

    variable _families
    variable _styleOff
    array set _styleOff [list bold normal italic roman]
    variable _sizes    {4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24}



































































    variable _widget
}


# ------------------------------------------------------------------------------
#  Command SelectFont::create
# ------------------------------------------------------------------------------
proc SelectFont::create { path args } {
    variable _families
    variable _sizes
#    variable _styles
    variable $path
    upvar 0  $path data




    if { ![info exists _families] } {

        loadfont
    }
    Widget::init SelectFont "$path#SelectFont" $args

    set bg [Widget::getoption "$path#SelectFont" -background]
    set _styles [Widget::getoption "$path#SelectFont" -styles]
    if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
        Dialog::create $path -modal local -default 0 -cancel 1 -background $bg \
            -title  [Widget::getoption "$path#SelectFont" -title] \
            -parent [Widget::getoption "$path#SelectFont" -parent]

................................................................................
                       -side top -anchor w -relief flat -background $bg]
        set sw    [ScrolledWindow::create [LabelFrame::getframe $labf1].sw \
                       -background $bg]
        set lbf   [listbox $sw.lb \
                       -height 5 -width 25 -exportselection false -selectmode browse]
        ScrolledWindow::setwidget $sw $lbf
        LabelFrame::configure $labf1 -focus $lbf
        eval $lbf insert end \
		$_families([Widget::getoption "$path#SelectFont" -families])





        set script "set SelectFont::$path\(family\) \[%W curselection\]; SelectFont::_update $path"
        bind $lbf <ButtonRelease-1> $script
        bind $lbf <space>           $script
        pack $sw -fill both -expand yes

        set labf2 [LabelFrame::create $topf.labf2 -text "Size" -name size \
                       -side top -anchor w -relief flat -background $bg]
................................................................................

        _getfont $path

        proc ::$path { cmd args } "return \[eval SelectFont::\$cmd $path \$args\]"

        return [_draw $path]
    } else {

	set fams [Widget::getoption "$path#SelectFont" -families]




        frame $path -relief flat -borderwidth 0 -background $bg
        bind $path <Destroy> "SelectFont::_destroy $path"
        set lbf [ComboBox::create $path.font \
                     -highlightthickness 0 -takefocus 0 -background $bg \
                     -values   $_families($fams) \
                     -textvariable SelectFont::$path\(family\) \
                     -editable 0 \
................................................................................
        proc ::$path { cmd args } "return \[eval SelectFont::\$cmd $path \$args\]"
    }

    return $path
}


# ------------------------------------------------------------------------------
#  Command SelectFont::configure
# ------------------------------------------------------------------------------
proc SelectFont::configure { path args } {
#    variable _styles
    set _styles [Widget::getoption "$path#SelectFont" -styles]

    set res [Widget::configure "$path#SelectFont" $args]

    if { [Widget::hasChanged "$path#SelectFont" -font font] } {
        _getfont $path
    }
................................................................................
            }
        }
    }
    return $res
}


# ------------------------------------------------------------------------------
#  Command SelectFont::cget
# ------------------------------------------------------------------------------
proc SelectFont::cget { path option } {
    return [Widget::cget "$path#SelectFont" $option]
}


# ------------------------------------------------------------------------------
#  Command SelectFont::loadfont
# ------------------------------------------------------------------------------
proc SelectFont::loadfont { } {
    variable _families

    # initialize families
    set _families(all) {}
    set _families(fixed) {}
    set _families(variable) {}
................................................................................
	    lappend _families(variable) $family
	}
    }
    return
}


# ------------------------------------------------------------------------------
#  Command SelectFont::_draw
# ------------------------------------------------------------------------------
proc SelectFont::_draw { path } {
    variable $path
    upvar 0  $path data

    $data(lbf) selection clear 0 end
    $data(lbf) selection set $data(family)
    $data(lbf) activate $data(family)
................................................................................
    unset data
    Widget::destroy "$path#SelectFont"
    destroy $path
    return $result
}


# ------------------------------------------------------------------------------
#  Command SelectFont::_destroy
# ------------------------------------------------------------------------------
proc SelectFont::_destroy { path } {
    variable $path
    upvar 0  $path data

    unset data
    Widget::destroy "$path#SelectFont"
    rename $path {}
}


# ------------------------------------------------------------------------------
#  Command SelectFont::_modstyle
# ------------------------------------------------------------------------------
proc SelectFont::_modstyle { path style } {
    variable $path
    upvar 0  $path data

    if { $data($style) == 1 } {
        $path.$style configure -relief raised
        set data($style) 0
................................................................................
        $path.$style configure -relief sunken
        set data($style) 1
    }
    _update $path
}


# ------------------------------------------------------------------------------
#  Command SelectFont::_update
# ------------------------------------------------------------------------------
proc SelectFont::_update { path } {
    variable _families
    variable _sizes
    variable _styleOff
    variable $path
    upvar 0  $path data

    set type [Widget::getoption "$path#SelectFont" -type]


    set fams [Widget::getoption "$path#SelectFont" -families]


    set _styles [Widget::getoption "$path#SelectFont" -styles]

    if { $type == "dialog" } {
        set curs [$path:cmd cget -cursor]
        $path:cmd configure -cursor watch
    }
    if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
        set font [list \
                      [lindex $_families($fams) $data(family)] \
................................................................................
        $path:cmd configure -cursor $curs
    } elseif { [set cmd [Widget::getoption "$path#SelectFont" -command]] != "" } {
        uplevel \#0 $cmd
    }
}


# ------------------------------------------------------------------------------
#  Command SelectFont::_getfont
# ------------------------------------------------------------------------------
proc SelectFont::_getfont { path } {
    variable _families
#    variable _styles
    variable _sizes
    variable $path
    upvar 0  $path data

    array set font [font actual [Widget::getoption "$path#SelectFont" -font]]
    set data(bold)       [expr {[string compare $font(-weight) "normal"] != 0}]
    set data(italic)     [expr {[string compare $font(-slant)  "roman"]  != 0}]
    set data(underline)  $font(-underline)
    set data(overstrike) $font(-overstrike)
    set _styles [Widget::getoption "$path#SelectFont" -styles]

    set fams [Widget::getoption "$path#SelectFont" -families]




    if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
        set idxf [lsearch $_families($fams) $font(-family)]
        set idxs [lsearch $_sizes    $font(-size)]
        set data(family) [expr {$idxf >= 0 ? $idxf : 0}]
        set data(size)   [expr {$idxs >= 0 ? $idxs : 0}]
    } else {
        set data(family) $font(-family)






|
|
|

|
|
|
>
|
|
|
<
>


>
|
>





|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




|

|



<



>
>
>
|
>


<
>







 







|
|
>
>
>
>
>







 







>
|
>
>
>
>







 







|

|

<







 







|

|





|

|







 







|

|







 







|

|










|

|







 







|

|








>
>
|
>
>
|
>







 







|

|


<





|
|



>
|
>
>
>
>







16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33

34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122

123
124
125
126
127
128
129
130
131
132

133
134
135
136
137
138
139
140
...
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
...
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
...
264
265
266
267
268
269
270
271
272
273
274

275
276
277
278
279
280
281
...
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
...
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
...
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
...
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
...
453
454
455
456
457
458
459
460
461
462
463
464

465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
namespace eval SelectFont {
    Dialog::use
    LabelFrame::use
    ScrolledWindow::use

    Widget::declare SelectFont {
        {-title		String		"Font selection" 0}
        {-parent	String		"" 0}
        {-background	TkResource	"" 0 frame}

        {-type		Enum		dialog        0 {dialog toolbar}}
        {-font		TkResource	""            0 label}
	{-families	String		"all"         1}
	{-querysystem	Boolean		1             0}
	{-styles	String		"bold italic underline overstrike" 1}
        {-command	String		""            0}
        {-sampletext	String		"Sample Text" 0}

        {-bg		Synonym		-background}
    }

    proc ::SelectFont { path args } { 
	return [eval SelectFont::create $path $args] 
    }
    proc use {} {}

    variable _families
    variable _styleOff
    array set _styleOff [list bold normal italic roman]
    variable _sizes     {4 5 6 7 8 9 10 11 12 13 14 15 16 \
	    17 18 19 20 21 22 23 24}
    
    # Set up preset lists of fonts, so the user can avoid the painfully slow
    # loadfont process if desired.
    if { [string equal $::tcl_platform(platform) "windows"] } {
	set presetVariable [list	\
		Arial			\
		{Arial Narrow}		\
		{Lucida Sans}		\
		{MS Sans Serif}		\
		{MS Serif}		\
		{Times New Roman}	\
		]
	set presetFixed    [list	\
		6x13			\
		7x14			\
		{Courier New}		\
		FixedSys		\
		Terminal		\
		]
	set presetAll      [list	\
		6x13			\
		7x14			\
		Arial			\
		{Arial Narrow}		\
		{Courier New}		\
		FixedSys		\
		{Lucida Sans}		\
		{MS Sans Serif}		\
		{MS Serif}		\
		Terminal		\
		{Times New Roman}	\
		]
    } else {
	set presetVariable [list	\
		helvetica		\
		lucida			\
		lucidabright		\
		{times new roman}	\
		]
	set presetFixed    [list	\
		courier			\
		fixed			\
		{lucida typewriter}	\
		screen			\
		serif			\
		terminal		\
		]
	set presetAll      [list	\
		courier			\
		fixed			\
		helvetica		\
		lucida			\
		lucidabright		\
		{lucida typewriter}	\
		screen			\
		serif			\
		terminal		\
		{times new roman}	\
		]
    }
    array set _families [list \
	    presetvariable	$presetVariable	\
	    presetfixed		$presetFixed	\
	    presetall		$presetAll	\
	    ]
		
    variable _widget
}


# ----------------------------------------------------------------------------
#  Command SelectFont::create
# ----------------------------------------------------------------------------
proc SelectFont::create { path args } {
    variable _families
    variable _sizes

    variable $path
    upvar 0  $path data

    # Initialize the internal rep of the widget options
    Widget::init SelectFont "$path#SelectFont" $args

    if { ![info exists _families(all)] && \
	    [Widget::getoption "$path#SelectFont" -querysystem] } {
        loadfont
    }


    set bg [Widget::getoption "$path#SelectFont" -background]
    set _styles [Widget::getoption "$path#SelectFont" -styles]
    if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
        Dialog::create $path -modal local -default 0 -cancel 1 -background $bg \
            -title  [Widget::getoption "$path#SelectFont" -title] \
            -parent [Widget::getoption "$path#SelectFont" -parent]

................................................................................
                       -side top -anchor w -relief flat -background $bg]
        set sw    [ScrolledWindow::create [LabelFrame::getframe $labf1].sw \
                       -background $bg]
        set lbf   [listbox $sw.lb \
                       -height 5 -width 25 -exportselection false -selectmode browse]
        ScrolledWindow::setwidget $sw $lbf
        LabelFrame::configure $labf1 -focus $lbf
	if { [Widget::getoption "$path#SelectFont" -querysystem] } {
	    set fam [Widget::getoption "$path#SelectFont" -families]
	} else {
	    set fam "preset"
	    append fam [Widget::getoption "$path#SelectFont" -families]
	}
        eval $lbf insert end $_families($fam)
        set script "set SelectFont::$path\(family\) \[%W curselection\]; SelectFont::_update $path"
        bind $lbf <ButtonRelease-1> $script
        bind $lbf <space>           $script
        pack $sw -fill both -expand yes

        set labf2 [LabelFrame::create $topf.labf2 -text "Size" -name size \
                       -side top -anchor w -relief flat -background $bg]
................................................................................

        _getfont $path

        proc ::$path { cmd args } "return \[eval SelectFont::\$cmd $path \$args\]"

        return [_draw $path]
    } else {
	if { [Widget::getoption "$path#SelectFont" -querysystem] } {
	    set fams [Widget::getoption "$path#SelectFont" -families]
	} else {
	    set fams "preset"
	    append fams [Widget::getoption "$path#SelectFont" -families]
	}
        frame $path -relief flat -borderwidth 0 -background $bg
        bind $path <Destroy> "SelectFont::_destroy $path"
        set lbf [ComboBox::create $path.font \
                     -highlightthickness 0 -takefocus 0 -background $bg \
                     -values   $_families($fams) \
                     -textvariable SelectFont::$path\(family\) \
                     -editable 0 \
................................................................................
        proc ::$path { cmd args } "return \[eval SelectFont::\$cmd $path \$args\]"
    }

    return $path
}


# ----------------------------------------------------------------------------
#  Command SelectFont::configure
# ----------------------------------------------------------------------------
proc SelectFont::configure { path args } {

    set _styles [Widget::getoption "$path#SelectFont" -styles]

    set res [Widget::configure "$path#SelectFont" $args]

    if { [Widget::hasChanged "$path#SelectFont" -font font] } {
        _getfont $path
    }
................................................................................
            }
        }
    }
    return $res
}


# ----------------------------------------------------------------------------
#  Command SelectFont::cget
# ----------------------------------------------------------------------------
proc SelectFont::cget { path option } {
    return [Widget::cget "$path#SelectFont" $option]
}


# ----------------------------------------------------------------------------
#  Command SelectFont::loadfont
# ----------------------------------------------------------------------------
proc SelectFont::loadfont { } {
    variable _families

    # initialize families
    set _families(all) {}
    set _families(fixed) {}
    set _families(variable) {}
................................................................................
	    lappend _families(variable) $family
	}
    }
    return
}


# ----------------------------------------------------------------------------
#  Command SelectFont::_draw
# ----------------------------------------------------------------------------
proc SelectFont::_draw { path } {
    variable $path
    upvar 0  $path data

    $data(lbf) selection clear 0 end
    $data(lbf) selection set $data(family)
    $data(lbf) activate $data(family)
................................................................................
    unset data
    Widget::destroy "$path#SelectFont"
    destroy $path
    return $result
}


# ----------------------------------------------------------------------------
#  Command SelectFont::_destroy
# ----------------------------------------------------------------------------
proc SelectFont::_destroy { path } {
    variable $path
    upvar 0  $path data

    unset data
    Widget::destroy "$path#SelectFont"
    rename $path {}
}


# ----------------------------------------------------------------------------
#  Command SelectFont::_modstyle
# ----------------------------------------------------------------------------
proc SelectFont::_modstyle { path style } {
    variable $path
    upvar 0  $path data

    if { $data($style) == 1 } {
        $path.$style configure -relief raised
        set data($style) 0
................................................................................
        $path.$style configure -relief sunken
        set data($style) 1
    }
    _update $path
}


# ----------------------------------------------------------------------------
#  Command SelectFont::_update
# ----------------------------------------------------------------------------
proc SelectFont::_update { path } {
    variable _families
    variable _sizes
    variable _styleOff
    variable $path
    upvar 0  $path data

    set type [Widget::getoption "$path#SelectFont" -type]
    set _styles [Widget::getoption "$path#SelectFont" -styles]
    if { [Widget::getoption "$path#SelectFont" -querysystem] } {
	set fams [Widget::getoption "$path#SelectFont" -families]
    } else {
	set fams "preset"
	append fams [Widget::getoption "$path#SelectFont" -families]
    }
    if { $type == "dialog" } {
        set curs [$path:cmd cget -cursor]
        $path:cmd configure -cursor watch
    }
    if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
        set font [list \
                      [lindex $_families($fams) $data(family)] \
................................................................................
        $path:cmd configure -cursor $curs
    } elseif { [set cmd [Widget::getoption "$path#SelectFont" -command]] != "" } {
        uplevel \#0 $cmd
    }
}


# ----------------------------------------------------------------------------
#  Command SelectFont::_getfont
# ----------------------------------------------------------------------------
proc SelectFont::_getfont { path } {
    variable _families

    variable _sizes
    variable $path
    upvar 0  $path data

    array set font [font actual [Widget::getoption "$path#SelectFont" -font]]
    set data(bold)    [expr {[string compare $font(-weight) "normal"] != 0}]
    set data(italic)  [expr {[string compare $font(-slant)  "roman"]  != 0}]
    set data(underline)  $font(-underline)
    set data(overstrike) $font(-overstrike)
    set _styles [Widget::getoption "$path#SelectFont" -styles]
    if { [Widget::getoption "$path#SelectFont" -querysystem] } {
	set fams [Widget::getoption "$path#SelectFont" -families]
    } else {
	set fams "preset"
	append fams [Widget::getoption "$path#SelectFont" -families]
    }
    if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
        set idxf [lsearch $_families($fams) $font(-family)]
        set idxs [lsearch $_sizes    $font(-size)]
        set data(family) [expr {$idxf >= 0 ? $idxf : 0}]
        set data(size)   [expr {$idxs >= 0 ? $idxs : 0}]
    } else {
        set data(family) $font(-family)