source: trunk/BWidget-1.2.1/font.tcl @ 984

Last change on this file since 984 was 931, checked in by toby, 11 years ago

include rest of files
File size: 13.5 KB
Line 
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        {-command    String     ""            0}
30        {-sampletext String     "Sample Text" 0}
31        {-bg         Synonym    -background}
32    }
33
34    proc ::SelectFont { path args } { return [eval SelectFont::create $path $args] }
35    proc use {} {}
36
37    variable _families
38    variable _styles   {bold italic underline overstrike}
39    variable _sizes    {4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24}
40
41    variable _widget
42}
43
44
45# ------------------------------------------------------------------------------
46#  Command SelectFont::create
47# ------------------------------------------------------------------------------
48proc SelectFont::create { path args } {
49    variable _families
50    variable _sizes
51    variable _styles
52    variable $path
53    upvar 0  $path data
54
55    if { ![info exists _families] } {
56        loadfont
57    }
58    Widget::init SelectFont "$path#SelectFont" $args
59    set bg [Widget::getoption "$path#SelectFont" -background]
60    if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
61        Dialog::create $path -modal local -default 0 -cancel 1 -background $bg \
62            -title  [Widget::getoption "$path#SelectFont" -title] \
63            -parent [Widget::getoption "$path#SelectFont" -parent]
64
65        set frame [Dialog::getframe $path]
66        set topf  [frame $frame.topf -relief flat -borderwidth 0 -background $bg]
67
68        set labf1 [LabelFrame::create $topf.labf1 -text "Font" -name font \
69                       -side top -anchor w -relief flat -background $bg]
70        set sw    [ScrolledWindow::create [LabelFrame::getframe $labf1].sw \
71                       -background $bg]
72        set lbf   [listbox $sw.lb \
73                       -height 5 -width 25 -exportselection false -selectmode browse]
74        ScrolledWindow::setwidget $sw $lbf
75        LabelFrame::configure $labf1 -focus $lbf
76        eval $lbf insert end $_families
77        set script "set SelectFont::$path\(family\) \[%W curselection\]; SelectFont::_update $path"
78        bind $lbf <ButtonRelease-1> $script
79        bind $lbf <space>           $script
80        pack $sw -fill both -expand yes
81
82        set labf2 [LabelFrame::create $topf.labf2 -text "Size" -name size \
83                       -side top -anchor w -relief flat -background $bg]
84        set sw    [ScrolledWindow::create [LabelFrame::getframe $labf2].sw \
85                       -scrollbar vertical -background $bg]
86        set lbs   [listbox $sw.lb \
87                       -height 5 -width 6 -exportselection false -selectmode browse]
88        ScrolledWindow::setwidget $sw $lbs
89        LabelFrame::configure $labf2 -focus $lbs
90        eval $lbs insert end $_sizes
91        set script "set SelectFont::$path\(size\) \[%W curselection\]; SelectFont::_update $path"
92        bind $lbs <ButtonRelease-1> $script
93        bind $lbs <space>           $script
94        pack $sw -fill both -expand yes
95
96        set labf3 [LabelFrame::create $topf.labf3 -text "Style" -name style \
97                       -side top -anchor w -relief sunken -bd 1 -background $bg]
98        set subf  [LabelFrame::getframe $labf3]
99        foreach st $_styles {
100            set name [lindex [BWidget::getname $st] 0]
101            if { $name == "" } {
102                set name "[string toupper [string index $name 0]][string range $name 1 end]"
103            }
104            checkbutton $subf.$st -text $name \
105                -variable   SelectFont::$path\($st\) \
106                -background $bg \
107                -command    "SelectFont::_update $path"
108            bind $subf.$st <Return> break
109            pack $subf.$st -anchor w
110        }
111        LabelFrame::configure $labf3 -focus $subf.[lindex $_styles 0]
112
113        pack $labf1 -side left -anchor n -fill both -expand yes
114        pack $labf2 -side left -anchor n -fill both -expand yes -padx 8
115        pack $labf3 -side left -anchor n -fill both -expand yes
116
117        set botf [frame $frame.botf -width 100 -height 50 \
118                      -bg white -bd 0 -relief flat \
119                      -highlightthickness 1 -takefocus 0 \
120                      -highlightbackground black \
121                      -highlightcolor black]
122
123        set lab  [label $botf.label \
124                      -background white -foreground black \
125                      -borderwidth 0 -takefocus 0 -highlightthickness 0 \
126                      -text [Widget::getoption "$path#SelectFont" -sampletext]]
127        place $lab -relx 0.5 -rely 0.5 -anchor c
128
129        pack $topf -pady 4 -fill both -expand yes
130        pack $botf -pady 4 -fill x
131
132        Dialog::add $path -name ok
133        Dialog::add $path -name cancel
134
135        set data(label) $lab
136        set data(lbf)   $lbf
137        set data(lbs)   $lbs
138
139        _getfont $path
140
141        proc ::$path { cmd args } "return \[eval SelectFont::\$cmd $path \$args\]"
142
143        return [_draw $path]
144    } else {
145        frame $path -relief flat -borderwidth 0 -background $bg
146        bind $path <Destroy> "SelectFont::_destroy $path"
147        set lbf [ComboBox::create $path.font \
148                     -highlightthickness 0 -takefocus 0 -background $bg \
149                     -values   $_families \
150                     -textvariable SelectFont::$path\(family\) \
151                     -editable 0 \
152                     -modifycmd "SelectFont::_update $path"]
153        set lbs [ComboBox::create $path.size \
154                     -highlightthickness 0 -takefocus 0 -background $bg \
155                     -width    4 \
156                     -values   $_sizes \
157                     -textvariable SelectFont::$path\(size\) \
158                     -editable 0 \
159                     -modifycmd "SelectFont::_update $path"]
160        pack $lbf -side left -anchor w
161        pack $lbs -side left -anchor w -padx 4
162        foreach st $_styles {
163            button $path.$st \
164                -highlightthickness 0 -takefocus 0 -padx 0 -pady 0 -bd 2 \
165                -background $bg \
166                -image  [Bitmap::get $st] \
167                -command "SelectFont::_modstyle $path $st"
168            pack $path.$st -side left -anchor w
169        }
170        set data(label) ""
171        set data(lbf)   $lbf
172        set data(lbs)   $lbs
173        _getfont $path
174
175        rename $path ::$path:cmd
176        proc ::$path { cmd args } "return \[eval SelectFont::\$cmd $path \$args\]"
177    }
178
179    return $path
180}
181
182
183# ------------------------------------------------------------------------------
184#  Command SelectFont::configure
185# ------------------------------------------------------------------------------
186proc SelectFont::configure { path args } {
187    variable _styles
188
189    set res [Widget::configure "$path#SelectFont" $args]
190
191    if { [Widget::hasChanged "$path#SelectFont" -font font] } {
192        _getfont $path
193    }
194    if { [Widget::hasChanged "$path#SelectFont" -background bg] } {
195        switch -- [Widget::getoption "$path#SelectFont" -type] {
196            dialog {
197                Dialog::configure $path -background $bg
198                set topf [Dialog::getframe $path].topf
199                $topf configure -background $bg
200                foreach labf {labf1 labf2} {
201                    LabelFrame::configure $topf.$labf -background $bg
202                    set subf [LabelFrame::getframe $topf.$labf]
203                    ScrolledWindow::configure $subf.sw -background $bg
204                    $subf.sw.lb configure -background $bg
205                }
206                LabelFrame::configure $topf.labf3 -background $bg
207                set subf [LabelFrame::getframe $topf.labf3]
208                foreach w [winfo children $subf] {
209                    $w configure -background $bg
210                }
211            }
212            toolbar {
213                $path configure -background $bg
214                ComboBox::configure $path.font -background $bg
215                ComboBox::configure $path.size -background $bg
216                foreach st $_styles {
217                    $path.$st configure -background $bg
218                }
219            }
220        }
221    }
222    return $res
223}
224
225
226# ------------------------------------------------------------------------------
227#  Command SelectFont::cget
228# ------------------------------------------------------------------------------
229proc SelectFont::cget { path option } {
230    return [Widget::cget "$path#SelectFont" $option]
231}
232
233
234# ------------------------------------------------------------------------------
235#  Command SelectFont::loadfont
236# ------------------------------------------------------------------------------
237proc SelectFont::loadfont { } {
238    variable _families
239
240    # initialize families
241    set _families {}
242    set lfont     [font families]
243    lappend lfont times courier helvetica
244    foreach font $lfont {
245        set family [font actual [list $font] -family]
246        if { [lsearch -exact $_families $family] == -1 } {
247            lappend _families $family
248        }
249    }
250    set _families [lsort $_families]
251}
252
253
254# ------------------------------------------------------------------------------
255#  Command SelectFont::_draw
256# ------------------------------------------------------------------------------
257proc SelectFont::_draw { path } {
258    variable $path
259    upvar 0  $path data
260
261    $data(lbf) selection clear 0 end
262    $data(lbf) selection set $data(family)
263    $data(lbf) activate $data(family)
264    $data(lbf) see $data(family)
265    $data(lbs) selection clear 0 end
266    $data(lbs) selection set $data(size)
267    $data(lbs) activate $data(size)
268    $data(lbs) see $data(size)
269    _update $path
270
271    if { [Dialog::draw $path] == 0 } {
272        set result [Widget::getoption "$path#SelectFont" -font]
273    } else {
274        set result ""
275    }
276    unset data
277    Widget::destroy "$path#SelectFont"
278    destroy $path
279    return $result
280}
281
282
283# ------------------------------------------------------------------------------
284#  Command SelectFont::_destroy
285# ------------------------------------------------------------------------------
286proc SelectFont::_destroy { path } {
287    variable $path
288    upvar 0  $path data
289
290    unset data
291    Widget::destroy "$path#SelectFont"
292    rename $path {}
293}
294
295
296# ------------------------------------------------------------------------------
297#  Command SelectFont::_modstyle
298# ------------------------------------------------------------------------------
299proc SelectFont::_modstyle { path style } {
300    variable $path
301    upvar 0  $path data
302
303    if { $data($style) == 1 } {
304        $path.$style configure -relief raised
305        set data($style) 0
306    } else {
307        $path.$style configure -relief sunken
308        set data($style) 1
309    }
310    _update $path
311}
312
313
314# ------------------------------------------------------------------------------
315#  Command SelectFont::_update
316# ------------------------------------------------------------------------------
317proc SelectFont::_update { path } {
318    variable _families
319    variable _sizes
320    variable _styles
321    variable $path
322    upvar 0  $path data
323
324    set type [Widget::getoption "$path#SelectFont" -type]
325    if { $type == "dialog" } {
326        set curs [$path:cmd cget -cursor]
327        $path:cmd configure -cursor watch
328    }
329    if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
330        set font [list \
331                      [lindex $_families $data(family)] \
332                      [lindex $_sizes $data(size)]]
333    } else {
334        set font [list $data(family) $data(size)]
335    }
336    foreach st $_styles {
337        if { $data($st) } {
338            lappend font $st
339        }
340    }
341    Widget::setoption "$path#SelectFont" -font $font
342    if { $type == "dialog" } {
343        $data(label) configure -font $font
344        $path:cmd configure -cursor $curs
345    } elseif { [set cmd [Widget::getoption "$path#SelectFont" -command]] != "" } {
346        uplevel \#0 $cmd
347    }
348}
349
350
351# ------------------------------------------------------------------------------
352#  Command SelectFont::_getfont
353# ------------------------------------------------------------------------------
354proc SelectFont::_getfont { path } {
355    variable _families
356    variable _styles
357    variable _sizes
358    variable $path
359    upvar 0  $path data
360
361    array set font [font actual [Widget::getoption "$path#SelectFont" -font]]
362    set data(bold)       [expr {[string compare $font(-weight) "normal"] != 0}]
363    set data(italic)     [expr {[string compare $font(-slant)  "roman"]  != 0}]
364    set data(underline)  $font(-underline)
365    set data(overstrike) $font(-overstrike)
366    if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
367        set idxf [lsearch $_families $font(-family)]
368        set idxs [lsearch $_sizes    $font(-size)]
369        set data(family) [expr {$idxf >= 0 ? $idxf : 0}]
370        set data(size)   [expr {$idxs >= 0 ? $idxs : 0}]
371    } else {
372        set data(family) $font(-family)
373        set data(size)   $font(-size)
374        foreach st $_styles {
375            $path.$st configure -relief [expr {$data($st) ? "sunken":"raised"}]
376        }
377    }
378}
379
Note: See TracBrowser for help on using the repository browser.