Tk Source Code

Changes On Branch bug-f75190db19
Login
☰Core Home Timeline Branches Tags Tickets Download Wiki
Hide Diff Patch Unified Diff

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

Changes In Branch bug-f75190db19 Excluding Merge-Ins

This is equivalent to a diff from 178b2141 to 894a7a81

2022-02-25
23:26
Fix [f75190db19]: ::tk::fontchooser of contains a couple of issues. check-in: 39a07baf user: fvogel tags: core-8-6-branch
2022-01-13
22:49
Remove proc ::tk::fontchooser::actual as this does not look right to me and creates issue #15 (see ticket [f75190db19]). Closed-Leaf check-in: 894a7a81 user: fvogel tags: bug-f75190db19
21:50
Typo in comment check-in: 57e7ca4b user: fvogel tags: bug-f75190db19
2021-11-06
14:23
Fix [46c2f088a2]: ttk::radiobutton -compound accepts empty string. Only a very minor documentation wording changed. check-in: d1323655 user: fvogel tags: core-8-6-branch
12:52
Fix [f75190db19]: ::tk::fontchooser of contains a couple of issues check-in: 026142fc user: fvogel tags: bug-f75190db19
2021-11-05
22:26
merge 8.6 check-in: 37cf295c user: dgp tags: trunk, main
22:21
merge release check-in: 178b2141 user: dgp tags: core-8-6-branch
2021-11-02
18:17
Merge 8.6 Closed-Leaf check-in: b3fc94ce user: culler tags: rc2, release, core-8-6-12-rc, core-8-6-12
18:16
Add missing call to [parent endSheet]. check-in: fa412516 user: culler tags: core-8-6-branch

Changes to library/fontchooser.tcl.

︙︙
8
9
10
11
12
13
14
15
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

# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

namespace eval ::tk::fontchooser {
    variable S

    set S(W) .__tk__fontchooser
    set S(fonts) [lsort -dictionary [font families]]
    set S(styles) [list \
	[::msgcat::mc "Regular"] \
	[::msgcat::mc "Italic"] \
	[::msgcat::mc "Bold"] \
	[::msgcat::mc "Bold Italic"] \
    ]

    set S(sizes) {8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72}
    set S(strike) 0
    set S(under) 0
    set S(first) 1
    set S(sampletext) [::msgcat::mc "AaBbYyZz01"]
    set S(-parent) .
    set S(-title) [::msgcat::mc "Font"]
    set S(-command) ""
    set S(-font) TkDefaultFont





















}

proc ::tk::fontchooser::Setup {} {
    variable S

    # Canonical versions of font families, styles, etc. for easier searching
    set S(fonts,lcase) {}
    foreach font $S(fonts) {lappend S(fonts,lcase) [string tolower $font]}
    set S(styles,lcase) {}
    foreach style $S(styles) {lappend S(styles,lcase) [string tolower $style]}
    set S(sizes,lcase) $S(sizes)

    ::ttk::style layout FontchooserFrame {
        Entry.field -sticky news -border true -children {
            FontchooserFrame.padding -sticky news
        }
    }
    bind [winfo class .] <<ThemeChanged>> \
        [list +ttk::style layout FontchooserFrame \
             [ttk::style layout FontchooserFrame]]

    namespace ensemble create -map {
        show ::tk::fontchooser::Show
        hide ::tk::fontchooser::Hide
        configure ::tk::fontchooser::Configure
    }
}
::tk::fontchooser::Setup

proc ::tk::fontchooser::Show {} {
    variable S



    if {![winfo exists $S(W)]} {
        Create
        wm transient $S(W) [winfo toplevel $S(-parent)]
        tk::PlaceWindow $S(W) widget $S(-parent)




    }

    set S(fonts) [lsort -dictionary [font families]]
    set S(fonts,lcase) {}

    foreach font $S(fonts) { lappend S(fonts,lcase) [string tolower $font]}

    wm deiconify $S(W)
}

proc ::tk::fontchooser::Hide {} {
    variable S
    wm withdraw $S(W)
}








|

|
|
|
|

<




<

|


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





|
<
<
<
<
<







|
|










|
>
>
>




>
>
>
>
|
>
|

>
|
>








8
9
10
11
12
13
14
15
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

# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

namespace eval ::tk::fontchooser {
    variable S

    set S(W) .__tk__fontchooser
    set S(fonts) [lsort -dictionary -unique [font families]]
    set S(styles) [list \
            [::msgcat::mc Regular] \
            [::msgcat::mc Italic] \
            [::msgcat::mc Bold] \
            [::msgcat::mc {Bold Italic}] \
    ]

    set S(sizes) {8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72}
    set S(strike) 0
    set S(under) 0
    set S(first) 1

    set S(-parent) .
    set S(-title) {}
    set S(-command) ""
    set S(-font) TkDefaultFont
    set S(bad) [list ]
}

proc ::tk::fontchooser::Canonical {} {
    variable S

    foreach style $S(styles) {
        lappend S(styles,lcase) [string tolower $style]
    }
    set S(sizes,lcase) $S(sizes)
    set S(sampletext) [::msgcat::mc "AaBbYyZz01"]

    # Canonical versions of font families, styles, etc. for easier searching
    set S(fonts,lcase) {}
    foreach font $S(fonts) {
        lappend S(fonts,lcase) [string tolower $font]
    }
    set S(styles,lcase) {}
    foreach style $S(styles) {
        lappend S(styles,lcase) [string tolower $style]
    }
}

proc ::tk::fontchooser::Setup {} {
    variable S

    Canonical






    ::ttk::style layout FontchooserFrame {
        Entry.field -sticky news -border true -children {
            FontchooserFrame.padding -sticky news
        }
    }
    bind [winfo class .] <<ThemeChanged>> \
            [list +ttk::style layout FontchooserFrame \
                    [ttk::style layout FontchooserFrame]]

    namespace ensemble create -map {
        show ::tk::fontchooser::Show
        hide ::tk::fontchooser::Hide
        configure ::tk::fontchooser::Configure
    }
}
::tk::fontchooser::Setup

proc ::tk::fontchooser::Show {} {
    variable S 

    Canonical

    if {![winfo exists $S(W)]} {
        Create
        wm transient $S(W) [winfo toplevel $S(-parent)]
        tk::PlaceWindow $S(W) widget $S(-parent)
        if {[string trim $S(-title)] eq ""} {
            wm title $S(W) [::msgcat::mc "Font"]
        } else {
            wm title $S(W) $S(-title)
        }
    }
    set S(fonts) [lsort -dictionary -unique [font families]]
    set S(fonts,lcase) {}
    foreach font $S(fonts) {
        lappend S(fonts,lcase) [string tolower $font]
    }
    wm deiconify $S(W)
}

proc ::tk::fontchooser::Hide {} {
    variable S
    wm withdraw $S(W)
}
︙︙
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
141
142
143


144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205


206
207
208
209
210
211
212

    }

    if {[llength $args] == 0} {
        set result {}
        foreach spec $specs {
            foreach {name xx yy default} $spec break
            lappend result $name \
                [expr {[info exists S($name)] ? $S($name) : $default}]
        }
        lappend result -visible \
            [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}]
        return $result
    }
    if {[llength $args] == 1} {
        set option [lindex $args 0]
        if {[string equal $option "-visible"]} {
            return [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}]
        } elseif {[info exists S($option)]} {
            return $S($option)
        }
        return -code error -errorcode [list TK LOOKUP OPTION $option] \
	    "bad option \"$option\": must be\
            -command, -font, -parent, -title or -visible"
    }

    set cache [dict create -parent $S(-parent) -title $S(-title) \
                   -font $S(-font) -command $S(-command)]
    set r [tclParseConfigSpec [namespace which -variable S] $specs DONTSETDEFAULTS $args]
    if {![winfo exists $S(-parent)]} {
	set code [list TK LOOKUP WINDOW $S(-parent)]
        set err "bad window path name \"$S(-parent)\""
        array set S $cache
        return -code error -errorcode $code $err
    }
    if {[string trim $S(-title)] eq ""} {
        set S(-title) [::msgcat::mc "Font"]
    }
    if {[winfo exists $S(W)] && ("-font" in $args)} {

	Init $S(-font)
	event generate $S(-parent) <<TkFontchooserFontChanged>>









    }
    return $r
}

proc ::tk::fontchooser::Create {} {
    variable S
    set windowName __tk__fontchooser
    if {$S(-parent) eq "."} {
        set S(W) .$windowName
    } else {
        set S(W) $S(-parent).$windowName
    }

    # Now build the dialog
    if {![winfo exists $S(W)]} {
        toplevel $S(W) -class TkFontDialog
        if {[package provide tcltest] ne {}} {set ::tk_dialog $S(W)}


        wm withdraw $S(W)
        wm title $S(W) $S(-title)
        wm transient $S(W) [winfo toplevel $S(-parent)]

        set scaling [tk scaling]
        set sizeWidth [expr {int([string length [::msgcat::mc "&Size:"]] * $scaling)}]

        set outer [::ttk::frame $S(W).outer -padding {10 10}]
        ::tk::AmpWidget ::ttk::label $S(W).font -text [::msgcat::mc "&Font:"]
        ::tk::AmpWidget ::ttk::label $S(W).style -text [::msgcat::mc "Font st&yle:"]
        ::tk::AmpWidget ::ttk::label $S(W).size -text [::msgcat::mc "&Size:"] -width $sizeWidth
        ttk::entry $S(W).efont -width 18 \
            -textvariable [namespace which -variable S](font)
        ttk::entry $S(W).estyle -width 10 \
            -textvariable [namespace which -variable S](style)
        ttk::entry $S(W).esize -textvariable [namespace which -variable S](size) \
            -width 3 -validate key -validatecommand {string is double %P}

        ttk_slistbox $S(W).lfonts -height 7 -exportselection 0 \
            -selectmode browse -activestyle none \
            -listvariable [namespace which -variable S](fonts)
        ttk_slistbox $S(W).lstyles -width 5 -height 7 -exportselection 0 \
            -selectmode browse -activestyle none \
            -listvariable [namespace which -variable S](styles)
        ttk_slistbox $S(W).lsizes -width 4 -height 7 -exportselection 0 \
            -selectmode browse -activestyle none \
            -listvariable [namespace which -variable S](sizes)

        set WE $S(W).effects
        ::ttk::labelframe $WE -text [::msgcat::mc "Effects"]
        ::tk::AmpWidget ::ttk::checkbutton $WE.strike \
            -variable [namespace which -variable S](strike) \
            -text [::msgcat::mc "Stri&keout"] \
            -command [namespace code [list Click strike]]
        ::tk::AmpWidget ::ttk::checkbutton $WE.under \
            -variable [namespace which -variable S](under) \
            -text [::msgcat::mc "&Underline"] \
            -command [namespace code [list Click under]]

        set bbox [::ttk::frame $S(W).bbox]
        ::ttk::button $S(W).ok -text [::msgcat::mc OK] -default active\
            -command [namespace code [list Done 1]]
        ::ttk::button $S(W).cancel -text [::msgcat::mc Cancel] \
            -command [namespace code [list Done 0]]
        ::tk::AmpWidget ::ttk::button $S(W).apply -text [::msgcat::mc "&Apply"] \
            -command [namespace code [list Apply]]
        wm protocol $S(W) WM_DELETE_WINDOW [namespace code [list Done 0]]

        # Calculate minimum sizes
        ttk::scrollbar $S(W).tmpvs
        set scroll_width [winfo reqwidth $S(W).tmpvs]
        destroy $S(W).tmpvs
        set minsize(gap) 10
        set minsize(bbox) [winfo reqwidth $S(W).ok]
        set minsize(fonts) \
            [expr {[font measure TkDefaultFont "Helvetica"] + $scroll_width}]
        set minsize(styles) \
            [expr {[font measure TkDefaultFont "Bold Italic"] + $scroll_width}]
        set minsize(sizes) \
            [expr {[font measure TkDefaultFont "-99"] + $scroll_width}]
        set min [expr {$minsize(gap) * 4}]
        foreach {what width} [array get minsize] {incr min $width}


        wm minsize $S(W) $min 260

        bind $S(W) <Return> [namespace code [list Done 1]]
        bind $S(W) <Escape> [namespace code [list Done 0]]
        bind $S(W) <Map> [namespace code [list Visibility %W 1]]
        bind $S(W) <Unmap> [namespace code [list Visibility %W 0]]
        bind $S(W) <Destroy> [namespace code [list Visibility %W 0]]








|


|










|
|

<

|


|




<
<
|
|
>
|
|
>
>
>
>
>
>
>
>
>
















|
>
>












|

|

|


|
|

|
|

|
|




|
|
|

|
|
|



|

|

|









|

|

|

|
>
>








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
141
142
143


144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247

    }

    if {[llength $args] == 0} {
        set result {}
        foreach spec $specs {
            foreach {name xx yy default} $spec break
            lappend result $name \
                    [expr {[info exists S($name)] ? $S($name) : $default}]
        }
        lappend result -visible \
                [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}]
        return $result
    }
    if {[llength $args] == 1} {
        set option [lindex $args 0]
        if {[string equal $option "-visible"]} {
            return [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}]
        } elseif {[info exists S($option)]} {
            return $S($option)
        }
        return -code error -errorcode [list TK LOOKUP OPTION $option] \
                "bad option \"$option\": must be\
                -command, -font, -parent, -title or -visible"
    }

    set cache [dict create -parent $S(-parent) -title $S(-title) \
            -font $S(-font) -command $S(-command)]
    set r [tclParseConfigSpec [namespace which -variable S] $specs DONTSETDEFAULTS $args]
    if {![winfo exists $S(-parent)]} {
        set code [list TK LOOKUP WINDOW $S(-parent)]
        set err "bad window path name \"$S(-parent)\""
        array set S $cache
        return -code error -errorcode $code $err
    }



    if {[winfo exists $S(W)]} {
        if {{-font} in $args} {
            Init $S(-font)
            event generate $S(-parent) <<TkFontchooserFontChanged>>
        }

        if {[string trim $S(-title)] eq {}} {
            wm title $S(W) [::msgcat::mc Font]
        } else {
            wm title $S(W) $S(-title)
        }
        $S(W).ok configure -state $S(nstate)
        $S(W).apply configure -state $S(nstate)
    }
    return $r
}

proc ::tk::fontchooser::Create {} {
    variable S
    set windowName __tk__fontchooser
    if {$S(-parent) eq "."} {
        set S(W) .$windowName
    } else {
        set S(W) $S(-parent).$windowName
    }

    # Now build the dialog
    if {![winfo exists $S(W)]} {
        toplevel $S(W) -class TkFontDialog
        if {[package provide tcltest] ne {}} {
            set ::tk_dialog $S(W)
        }
        wm withdraw $S(W)
        wm title $S(W) $S(-title)
        wm transient $S(W) [winfo toplevel $S(-parent)]

        set scaling [tk scaling]
        set sizeWidth [expr {int([string length [::msgcat::mc "&Size:"]] * $scaling)}]

        set outer [::ttk::frame $S(W).outer -padding {10 10}]
        ::tk::AmpWidget ::ttk::label $S(W).font -text [::msgcat::mc "&Font:"]
        ::tk::AmpWidget ::ttk::label $S(W).style -text [::msgcat::mc "Font st&yle:"]
        ::tk::AmpWidget ::ttk::label $S(W).size -text [::msgcat::mc "&Size:"] -width $sizeWidth
        ttk::entry $S(W).efont -width 18 \
                -textvariable [namespace which -variable S](font)
        ttk::entry $S(W).estyle -width 10 \
                -textvariable [namespace which -variable S](style)
        ttk::entry $S(W).esize -textvariable [namespace which -variable S](size) \
                -width 3 -validate key -validatecommand {regexp -- {^-*[0-9]*$} %P}

        ttk_slistbox $S(W).lfonts -height 7 -exportselection 0 \
                -selectmode browse -activestyle none \
                -listvariable [namespace which -variable S](fonts)
        ttk_slistbox $S(W).lstyles -width 5 -height 7 -exportselection 0 \
                -selectmode browse -activestyle none \
                -listvariable [namespace which -variable S](styles)
        ttk_slistbox $S(W).lsizes -width 4 -height 7 -exportselection 0 \
                -selectmode browse -activestyle none \
                -listvariable [namespace which -variable S](sizes)

        set WE $S(W).effects
        ::ttk::labelframe $WE -text [::msgcat::mc "Effects"]
        ::tk::AmpWidget ::ttk::checkbutton $WE.strike \
                -variable [namespace which -variable S](strike) \
                -text [::msgcat::mc "Stri&keout"] \
                -command [namespace code [list Click strike]]
        ::tk::AmpWidget ::ttk::checkbutton $WE.under \
                -variable [namespace which -variable S](under) \
                -text [::msgcat::mc "&Underline"] \
                -command [namespace code [list Click under]]

        set bbox [::ttk::frame $S(W).bbox]
        ::ttk::button $S(W).ok -text [::msgcat::mc OK] -default active\
                -command [namespace code [list Done 1]]
        ::ttk::button $S(W).cancel -text [::msgcat::mc Cancel] \
                -command [namespace code [list Done 0]]
        ::tk::AmpWidget ::ttk::button $S(W).apply -text [::msgcat::mc "&Apply"] \
                -command [namespace code [list Apply]]
        wm protocol $S(W) WM_DELETE_WINDOW [namespace code [list Done 0]]

        # Calculate minimum sizes
        ttk::scrollbar $S(W).tmpvs
        set scroll_width [winfo reqwidth $S(W).tmpvs]
        destroy $S(W).tmpvs
        set minsize(gap) 10
        set minsize(bbox) [winfo reqwidth $S(W).ok]
        set minsize(fonts) \
                [expr {[font measure TkDefaultFont "Helvetica"] + $scroll_width}]
        set minsize(styles) \
                [expr {[font measure TkDefaultFont "Bold Italic"] + $scroll_width}]
        set minsize(sizes) \
                [expr {[font measure TkDefaultFont "-99"] + $scroll_width}]
        set min [expr {$minsize(gap) * 4}]
        foreach {what width} [array get minsize] {
            incr min $width
        }
        wm minsize $S(W) $min 260

        bind $S(W) <Return> [namespace code [list Done 1]]
        bind $S(W) <Escape> [namespace code [list Done 0]]
        bind $S(W) <Map> [namespace code [list Visibility %W 1]]
        bind $S(W) <Unmap> [namespace code [list Visibility %W 0]]
        bind $S(W) <Destroy> [namespace code [list Visibility %W 0]]
︙︙
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245

        bind $S(W).apply <<AltUnderlined>> [namespace code [list Apply]]
        bind $WE.strike <<AltUnderlined>> [list $WE.strike invoke]
        bind $WE.under <<AltUnderlined>> [list $WE.under invoke]

        set WS $S(W).sample
        ::ttk::labelframe $WS -text [::msgcat::mc "Sample"]
        ::ttk::label $WS.sample -relief sunken -anchor center \
            -textvariable [namespace which -variable S](sampletext)
        set S(sample) $WS.sample
        grid $WS.sample -sticky news -padx 6 -pady 4
        grid rowconfigure $WS 0 -weight 1
        grid columnconfigure $WS 0 -weight 1
        grid propagate $WS 0

        grid $S(W).ok     -in $bbox -sticky new -pady {0 2}
        grid $S(W).cancel -in $bbox -sticky new -pady 2
        if {$S(-command) ne ""} {
            grid $S(W).apply -in $bbox -sticky new -pady 2
        }
        grid columnconfigure $bbox 0 -weight 1

        grid $WE.strike -sticky w -padx 10
        grid $WE.under -sticky w -padx 10 -pady {0 30}
        grid columnconfigure $WE 1 -weight 1

        grid $S(W).font   x $S(W).style   x $S(W).size   x       -in $outer -sticky w








|








<
|
<








255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270

271

272
273
274
275
276
277
278

        bind $S(W).apply <<AltUnderlined>> [namespace code [list Apply]]
        bind $WE.strike <<AltUnderlined>> [list $WE.strike invoke]
        bind $WE.under <<AltUnderlined>> [list $WE.under invoke]

        set WS $S(W).sample
        ::ttk::labelframe $WS -text [::msgcat::mc "Sample"]
        ::ttk::label $WS.sample -relief sunken -anchor center \
                -textvariable [namespace which -variable S](sampletext)
        set S(sample) $WS.sample
        grid $WS.sample -sticky news -padx 6 -pady 4
        grid rowconfigure $WS 0 -weight 1
        grid columnconfigure $WS 0 -weight 1
        grid propagate $WS 0

        grid $S(W).ok     -in $bbox -sticky new -pady {0 2}
        grid $S(W).cancel -in $bbox -sticky new -pady 2

        grid $S(W).apply  -in $bbox -sticky new -pady 2

        grid columnconfigure $bbox 0 -weight 1

        grid $WE.strike -sticky w -padx 10
        grid $WE.under -sticky w -padx 10 -pady {0 30}
        grid columnconfigure $WE 1 -weight 1

        grid $S(W).font   x $S(W).style   x $S(W).size   x       -in $outer -sticky w
︙︙
258
259
260
261
262
263
264
265
266
267
268
269





270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292


293

294
295


296
297
298
299
300
301
302

        grid $outer -sticky news
        grid rowconfigure $S(W) 0 -weight 1
        grid columnconfigure $S(W) 0 -weight 1

        Init $S(-font)

        trace add variable [namespace which -variable S](size) \
            write [namespace code [list Tracer]]
        trace add variable [namespace which -variable S](style) \
            write [namespace code [list Tracer]]
        trace add variable [namespace which -variable S](font) \
            write [namespace code [list Tracer]]





    } else {
        Init $S(-font)
    }

    return
}

# ::tk::fontchooser::Done --
#
#       Handles teardown of the dialog, calling -command if needed
#
# Arguments:
#       ok              true if user pressed OK
#
proc ::tk::fontchooser::Done {ok} {
    variable S

    if {! $ok} {
        set S(result) ""
    }
    trace vdelete S(size) w [namespace code [list Tracer]]
    trace vdelete S(style) w [namespace code [list Tracer]]
    trace vdelete S(font) w [namespace code [list Tracer]]


    destroy $S(W)

    if {$ok && $S(-command) ne ""} {
        uplevel #0 $S(-command) [list $S(result)]


    }
}

# ::tk::fontchooser::Apply --
#
#	Call the -command procedure appending the current font
#	Errors are reported via the background error mechanism








|

|

|
>
>
>
>
>
|
|
<




















>
>

>
|
|
>
>








291
292
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
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344

        grid $outer -sticky news
        grid rowconfigure $S(W) 0 -weight 1
        grid columnconfigure $S(W) 0 -weight 1

        Init $S(-font)

        trace add variable [namespace which -variable S](size) \
                write [namespace code [list Tracer]]
        trace add variable [namespace which -variable S](style) \
                write [namespace code [list Tracer]]
        trace add variable [namespace which -variable S](font) \
                write [namespace code [list Tracer]]
        trace add variable [namespace which -variable S](strike) \
                write [namespace code [list Tracer]]
        trace add variable [namespace which -variable S](under) \
                write [namespace code [list Tracer]]
    }

    Init $S(-font)


    return
}

# ::tk::fontchooser::Done --
#
#       Handles teardown of the dialog, calling -command if needed
#
# Arguments:
#       ok              true if user pressed OK
#
proc ::tk::fontchooser::Done {ok} {
    variable S

    if {! $ok} {
        set S(result) ""
    }
    trace vdelete S(size) w [namespace code [list Tracer]]
    trace vdelete S(style) w [namespace code [list Tracer]]
    trace vdelete S(font) w [namespace code [list Tracer]]
    trace vdelete S(strike) w [namespace code [list Tracer]]
    trace vdelete S(under) w [namespace code [list Tracer]]
    destroy $S(W)
    if {$ok} {
        if {$S(-command) ne ""} {
            uplevel #0 $S(-command) [list $S(result)]
        }
        event generate $S(-parent) <<TkFontchooserFontChanged>>
    }
}

# ::tk::fontchooser::Apply --
#
#	Call the -command procedure appending the current font
#	Errors are reported via the background error mechanism
︙︙
318
319
320
321
322
323
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
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
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

398


399
400

401
402


403



404

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
437
438
439
440
441
442

# Arguments:
#       defaultFont     font to use as the default
#
proc ::tk::fontchooser::Init {{defaultFont ""}} {
    variable S

    if {$S(first) || $defaultFont ne ""} {

        if {$defaultFont eq ""} {
            set defaultFont [[entry .___e] cget -font]
            destroy .___e
        }
        array set F [font actual $defaultFont]
        set S(font) $F(-family)

        set S(size) $F(-size)
        set S(strike) $F(-overstrike)
        set S(under) $F(-underline)
        set S(style) [::msgcat::mc "Regular"]
        if {$F(-weight) eq "bold" && $F(-slant) eq "italic"} {
            set S(style) [::msgcat::mc "Bold Italic"]
        } elseif {$F(-weight) eq "bold"} {
            set S(style) [::msgcat::mc "Bold"]
        } elseif {$F(-slant) eq "italic"} {
            set S(style) [::msgcat::mc "Italic"]
        }

        set S(first) 0
    }

    Tracer a b c
    Update
}

# ::tk::fontchooser::Click --
#
#       Handles all button clicks, updating the appropriate widgets
#
# Arguments:
#       who             which widget got pressed
#
proc ::tk::fontchooser::Click {who} {
    variable S

    if {$who eq "font"} {
        set S(font) [$S(W).lfonts get [$S(W).lfonts curselection]]
    } elseif {$who eq "style"} {
        set S(style) [$S(W).lstyles get [$S(W).lstyles curselection]]
    } elseif {$who eq "size"} {
        set S(size) [$S(W).lsizes get [$S(W).lsizes curselection]]
    }
    Update
}

# ::tk::fontchooser::Tracer --
#
#       Handles traces on key variables, updating the appropriate widgets
#
# Arguments:
#       standard trace arguments (not used)
#
proc ::tk::fontchooser::Tracer {var1 var2 op} {
    variable S

    set bad 0
    set nstate normal
    # Make selection in each listbox
    foreach var {font style size} {
        set value [string tolower $S($var)]
        $S(W).l${var}s selection clear 0 end
        set n [lsearch -exact $S(${var}s,lcase) $value]
        $S(W).l${var}s selection set $n
        if {$n >= 0} {
            set S($var) [lindex $S(${var}s) $n]
            $S(W).e$var icursor end
            $S(W).e$var selection clear




        } else {                                ;# No match, try prefix
            # Size is weird: valid numbers are legal but don't display
            # unless in the font size list
            set n [lsearch -glob $S(${var}s,lcase) "$value*"]

            set bad 1
            if {$var ne "size" || ! [string is double -strict $value]} {

                set nstate disabled


            }
        }

        $S(W).l${var}s see $n
    }


    if {!$bad} {Update}



    $S(W).ok configure -state $nstate

}

# ::tk::fontchooser::Update --
#
#       Shows a sample of the currently selected font
#
proc ::tk::fontchooser::Update {} {
    variable S

    set S(result) [list $S(font) $S(size)]
    if {$S(style) eq [::msgcat::mc "Bold"]} {lappend S(result) bold}


    if {$S(style) eq [::msgcat::mc "Italic"]} {lappend S(result) italic}


    if {$S(style) eq [::msgcat::mc "Bold Italic"]} {lappend S(result) bold italic}


    if {$S(strike)} {lappend S(result) overstrike}


    if {$S(under)} {lappend S(result) underline}



    $S(sample) configure -font $S(result)

}

# ::tk::fontchooser::Visibility --
#
#	Notify the parent when the dialog visibility changes
#
proc ::tk::fontchooser::Visibility {w visible} {
    variable S
    if {$w eq $S(W)} {
        event generate $S(-parent) <<TkFontchooserVisibility>>
    }
}

# ::tk::fontchooser::ttk_listbox --
#
#	Create a properly themed scrolled listbox.
#	This is exactly right on XP but may need adjusting on other platforms.
#
proc ::tk::fontchooser::ttk_slistbox {w args} {
    set f [ttk::frame $w -style FontchooserFrame -padding 2]
    if {[catch {








>






>



<







<


<
<
<











<







<











|
|
<
|
<
|
|
|
|

|
|
|
>
>
>
>
|
<
<
|
>
|
|
>
|
>
>
|
|
>
|

>
>
|
>
>
>
|
>










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

>













|








360
361
362
363
364
365
366
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

398
399
400
401
402
403
404

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
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
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
488
489
490
491
492
493
494
495
496
497
498
499
500
501

# Arguments:
#       defaultFont     font to use as the default
#
proc ::tk::fontchooser::Init {{defaultFont ""}} {
    variable S

    if {$S(first) || $defaultFont ne ""} {
        Canonical
        if {$defaultFont eq ""} {
            set defaultFont [[entry .___e] cget -font]
            destroy .___e
        }
        array set F [font actual $defaultFont]
        set S(font) $F(-family)
        set S(style) [::msgcat::mc "Regular"]
        set S(size) $F(-size)
        set S(strike) $F(-overstrike)
        set S(under) $F(-underline)

        if {$F(-weight) eq "bold" && $F(-slant) eq "italic"} {
            set S(style) [::msgcat::mc "Bold Italic"]
        } elseif {$F(-weight) eq "bold"} {
            set S(style) [::msgcat::mc "Bold"]
        } elseif {$F(-slant) eq "italic"} {
            set S(style) [::msgcat::mc "Italic"]
        }

        set S(first) 0
    }



}

# ::tk::fontchooser::Click --
#
#       Handles all button clicks, updating the appropriate widgets
#
# Arguments:
#       who             which widget got pressed
#
proc ::tk::fontchooser::Click {who} {
    variable S

    if {$who eq "font"} {
        set S(font) [$S(W).lfonts get [$S(W).lfonts curselection]]
    } elseif {$who eq "style"} {
        set S(style) [$S(W).lstyles get [$S(W).lstyles curselection]]
    } elseif {$who eq "size"} {
        set S(size) [$S(W).lsizes get [$S(W).lsizes curselection]]
    }

}

# ::tk::fontchooser::Tracer --
#
#       Handles traces on key variables, updating the appropriate widgets
#
# Arguments:
#       standard trace arguments (not used)
#
proc ::tk::fontchooser::Tracer {var1 var2 op} {
    variable S
    # We don't need to process strike and under
    if {$var2 ni [list strike under]} {

        # Make selection in listbox

        set value [string tolower $S($var2)]
        $S(W).l${var2}s selection clear 0 end
        set n [lsearch -exact $S(${var2}s,lcase) $value]
        $S(W).l${var2}s selection set $n
        if {$n >= 0} {
            set S($var2) [lindex $S(${var2}s) $n]
            $S(W).e$var2 icursor end
            $S(W).e$var2 selection clear
            if {[set i [lsearch $S(bad) $var2]] >= 0} {
                set S(bad) [lreplace $S(bad) $i $i]
            }
        } else {
            # No match, try prefix


            set n [lsearch -glob $S(${var2}s,lcase) "$value*"]
            if {$var2 ne "size" || !([regexp -- {^(-[0-9]+|[0-9]+)$} $value] && $value >= -4096 && $value <= 4096)} {
                 if {[lsearch $S(bad) $var2] < 0} {
                     lappend S(bad) $var2
                 }
            } else {
                if {[set i [lsearch $S(bad) $var2]] >= 0} {
                    set S(bad) [lreplace $S(bad) $i $i]
                }
            }
        }
        $S(W).l${var2}s see $n
    }
    if {[llength $S(bad)] == 0} {
        set S(nstate) normal
        Update
    } else {
        set S(nstate) disabled
    }
    $S(W).ok configure -state $S(nstate)
    $S(W).apply configure -state $S(nstate)
}

# ::tk::fontchooser::Update --
#
#       Shows a sample of the currently selected font
#
proc ::tk::fontchooser::Update {} {
    variable S

    set S(result) [list $S(font) $S(size)]
    if {$S(style) eq [::msgcat::mc "Bold"]} {
        lappend S(result) bold
    }
    if {$S(style) eq [::msgcat::mc "Italic"]} {
        lappend S(result) italic
    }
    if {$S(style) eq [::msgcat::mc "Bold Italic"]} {
        lappend S(result) bold italic
    }
    if {$S(strike)} {
        lappend S(result) overstrike
    }
    if {$S(under)} {
        lappend S(result) underline
    }

    $S(sample) configure -font $S(result)
    set S(-font) $S(result)
}

# ::tk::fontchooser::Visibility --
#
#	Notify the parent when the dialog visibility changes
#
proc ::tk::fontchooser::Visibility {w visible} {
    variable S
    if {$w eq $S(W)} {
        event generate $S(-parent) <<TkFontchooserVisibility>>
    }
}

# ::tk::fontchooser::ttk_slistbox --
#
#	Create a properly themed scrolled listbox.
#	This is exactly right on XP but may need adjusting on other platforms.
#
proc ::tk::fontchooser::ttk_slistbox {w args} {
    set f [ttk::frame $w -style FontchooserFrame -padding 2]
    if {[catch {
︙︙

This page was generated in about 0.023s by Fossil 2.24 [f4ffefe708] 2024-04-17 14:02:19