]>
Commit | Line | Data |
---|---|---|
c80d7be5 PT |
1 | # Functions for supporting the use of themed Tk widgets in git-gui. |
2 | # Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net> | |
3 | ||
f50d5055 CB |
4 | proc ttk_get_current_theme {} { |
5 | # Handle either current Tk or older versions of 8.5 | |
6 | if {[catch {set theme [ttk::style theme use]}]} { | |
7 | set theme $::ttk::currentTheme | |
8 | } | |
9 | return $theme | |
10 | } | |
11 | ||
c80d7be5 PT |
12 | proc InitTheme {} { |
13 | # Create a color label style (bg can be overridden by widget option) | |
14 | ttk::style layout Color.TLabel { | |
15 | Color.Label.border -sticky news -children { | |
16 | Color.label.fill -sticky news -children { | |
17 | Color.Label.padding -sticky news -children { | |
18 | Color.Label.label -sticky news}}}} | |
19 | eval [linsert [ttk::style configure TLabel] 0 \ | |
20 | ttk::style configure Color.TLabel] | |
21 | ttk::style configure Color.TLabel \ | |
22 | -borderwidth 0 -relief flat -padding 2 | |
23 | ttk::style map Color.TLabel -background {{} gold} | |
24 | # We also need a padded label. | |
25 | ttk::style configure Padded.TLabel \ | |
26 | -padding {5 5} -borderwidth 1 -relief solid | |
27 | # We need a gold frame. | |
28 | ttk::style layout Gold.TFrame { | |
29 | Gold.Frame.border -sticky nswe -children { | |
30 | Gold.Frame.fill -sticky nswe}} | |
31 | ttk::style configure Gold.TFrame -background gold -relief flat | |
32 | # listboxes should have a theme border so embed in ttk::frame | |
33 | ttk::style layout SListbox.TFrame { | |
35927672 PT |
34 | SListbox.Frame.Entry.field -sticky news -border true -children { |
35 | SListbox.Frame.padding -sticky news | |
36 | } | |
37 | } | |
38 | ||
f50d5055 | 39 | set theme [ttk_get_current_theme] |
35927672 PT |
40 | |
41 | if {[lsearch -exact {default alt classic clam} $theme] != -1} { | |
42 | # Simple override of standard ttk::entry to change the field | |
43 | # packground according to a state flag. We should use 'user1' | |
44 | # but not all versions of 8.5 support that so make use of 'pressed' | |
45 | # which is not normally in use for entry widgets. | |
46 | ttk::style layout Edged.Entry [ttk::style layout TEntry] | |
47 | ttk::style map Edged.Entry {*}[ttk::style map TEntry] | |
48 | ttk::style configure Edged.Entry {*}[ttk::style configure TEntry] \ | |
49 | -fieldbackground lightgreen | |
50 | ttk::style map Edged.Entry -fieldbackground { | |
51 | {pressed !disabled} lightpink | |
52 | } | |
53 | } else { | |
54 | # For fancier themes, in particular the Windows ones, the field | |
55 | # element may not support changing the background color. So instead | |
56 | # override the fill using the default fill element. If we overrode | |
57 | # the vista theme field element we would loose the themed border | |
58 | # of the widget. | |
59 | catch { | |
60 | ttk::style element create color.fill from default | |
61 | } | |
62 | ||
63 | ttk::style layout Edged.Entry { | |
64 | Edged.Entry.field -sticky nswe -border 0 -children { | |
65 | Edged.Entry.border -sticky nswe -border 1 -children { | |
66 | Edged.Entry.padding -sticky nswe -children { | |
67 | Edged.Entry.color.fill -sticky nswe -children { | |
68 | Edged.Entry.textarea -sticky nswe | |
69 | } | |
70 | } | |
71 | } | |
72 | } | |
73 | } | |
74 | ||
75 | ttk::style configure Edged.Entry {*}[ttk::style configure TEntry] \ | |
76 | -background lightgreen -padding 0 -borderwidth 0 | |
77 | ttk::style map Edged.Entry {*}[ttk::style map TEntry] \ | |
78 | -background {{pressed !disabled} lightpink} | |
79 | } | |
80 | ||
81 | if {[lsearch [bind . <<ThemeChanged>>] InitTheme] == -1} { | |
82 | bind . <<ThemeChanged>> +[namespace code [list InitTheme]] | |
83 | } | |
c80d7be5 PT |
84 | } |
85 | ||
30508bc4 PT |
86 | # Define a style used for the surround of text widgets. |
87 | proc InitEntryFrame {} { | |
88 | ttk::style theme settings default { | |
89 | ttk::style layout EntryFrame { | |
90 | EntryFrame.field -sticky nswe -border 0 -children { | |
91 | EntryFrame.fill -sticky nswe -children { | |
92 | EntryFrame.padding -sticky nswe | |
93 | } | |
94 | } | |
95 | } | |
96 | ttk::style configure EntryFrame -padding 1 -relief sunken | |
97 | ttk::style map EntryFrame -background {} | |
98 | } | |
99 | ttk::style theme settings classic { | |
100 | ttk::style configure EntryFrame -padding 2 -relief sunken | |
101 | ttk::style map EntryFrame -background {} | |
102 | } | |
103 | ttk::style theme settings alt { | |
104 | ttk::style configure EntryFrame -padding 2 | |
105 | ttk::style map EntryFrame -background {} | |
106 | } | |
107 | ttk::style theme settings clam { | |
108 | ttk::style configure EntryFrame -padding 2 | |
109 | ttk::style map EntryFrame -background {} | |
110 | } | |
111 | ||
112 | # Ignore errors for missing native themes | |
113 | catch { | |
114 | ttk::style theme settings winnative { | |
115 | ttk::style configure EntryFrame -padding 2 | |
116 | } | |
117 | ttk::style theme settings xpnative { | |
118 | ttk::style configure EntryFrame -padding 1 | |
119 | ttk::style element create EntryFrame.field vsapi \ | |
120 | EDIT 1 {disabled 4 focus 3 active 2 {} 1} -padding 1 | |
121 | } | |
122 | ttk::style theme settings vista { | |
123 | ttk::style configure EntryFrame -padding 2 | |
124 | ttk::style element create EntryFrame.field vsapi \ | |
125 | EDIT 6 {disabled 4 focus 3 active 2 {} 1} -padding 2 | |
126 | } | |
127 | } | |
128 | ||
129 | bind EntryFrame <Enter> {%W instate !disabled {%W state active}} | |
130 | bind EntryFrame <Leave> {%W state !active} | |
131 | bind EntryFrame <<ThemeChanged>> { | |
132 | set pad [ttk::style lookup EntryFrame -padding] | |
133 | %W configure -padding [expr {$pad eq {} ? 1 : $pad}] | |
134 | } | |
135 | } | |
136 | ||
c80d7be5 PT |
137 | proc gold_frame {w args} { |
138 | global use_ttk | |
139 | if {$use_ttk} { | |
140 | eval [linsert $args 0 ttk::frame $w -style Gold.TFrame] | |
141 | } else { | |
142 | eval [linsert $args 0 frame $w -background gold] | |
143 | } | |
144 | } | |
145 | ||
146 | proc tlabel {w args} { | |
147 | global use_ttk | |
148 | if {$use_ttk} { | |
149 | set cmd [list ttk::label $w -style Color.TLabel] | |
150 | foreach {k v} $args { | |
151 | switch -glob -- $k { | |
152 | -activebackground {} | |
153 | default { lappend cmd $k $v } | |
154 | } | |
155 | } | |
156 | eval $cmd | |
157 | } else { | |
158 | eval [linsert $args 0 label $w] | |
159 | } | |
160 | } | |
161 | ||
162 | # The padded label gets used in the about class. | |
163 | proc paddedlabel {w args} { | |
164 | global use_ttk | |
165 | if {$use_ttk} { | |
166 | eval [linsert $args 0 ttk::label $w -style Padded.TLabel] | |
167 | } else { | |
168 | eval [linsert $args 0 label $w \ | |
169 | -padx 5 -pady 5 \ | |
170 | -justify left \ | |
171 | -anchor w \ | |
172 | -borderwidth 1 \ | |
173 | -relief solid] | |
174 | } | |
175 | } | |
176 | ||
177 | # Create a toplevel for use as a dialog. | |
178 | # If available, sets the EWMH dialog hint and if ttk is enabled | |
179 | # place a themed frame over the surface. | |
180 | proc Dialog {w args} { | |
181 | eval [linsert $args 0 toplevel $w -class Dialog] | |
30508bc4 | 182 | catch {wm attributes $w -type dialog} |
c80d7be5 PT |
183 | pave_toplevel $w |
184 | return $w | |
185 | } | |
186 | ||
187 | # Tk toplevels are not themed - so pave it over with a themed frame to get | |
188 | # the base color correct per theme. | |
189 | proc pave_toplevel {w} { | |
190 | global use_ttk | |
191 | if {$use_ttk && ![winfo exists $w.!paving]} { | |
192 | set paving [ttk::frame $w.!paving] | |
193 | place $paving -x 0 -y 0 -relwidth 1 -relheight 1 | |
194 | lower $paving | |
195 | } | |
196 | } | |
197 | ||
198 | # Create a scrolled listbox with appropriate border for the current theme. | |
199 | # On many themes the border for a scrolled listbox needs to go around the | |
200 | # listbox and the scrollbar. | |
201 | proc slistbox {w args} { | |
202 | global use_ttk NS | |
203 | if {$use_ttk} { | |
204 | set f [ttk::frame $w -style SListbox.TFrame -padding 2] | |
205 | } else { | |
206 | set f [frame $w -relief flat] | |
207 | } | |
208 | if {[catch { | |
209 | if {$use_ttk} { | |
210 | eval [linsert $args 0 listbox $f.list -relief flat \ | |
211 | -highlightthickness 0 -borderwidth 0] | |
212 | } else { | |
213 | eval [linsert $args 0 listbox $f.list] | |
214 | } | |
215 | ${NS}::scrollbar $f.vs -command [list $f.list yview] | |
216 | $f.list configure -yscrollcommand [list $f.vs set] | |
217 | grid $f.list $f.vs -sticky news | |
218 | grid rowconfigure $f 0 -weight 1 | |
219 | grid columnconfigure $f 0 -weight 1 | |
220 | bind $f.list <<ListboxSelect>> \ | |
221 | [list event generate $w <<ListboxSelect>>] | |
222 | interp hide {} $w | |
223 | interp alias {} $w {} $f.list | |
224 | } err]} { | |
225 | destroy $f | |
226 | return -code error $err | |
227 | } | |
228 | return $w | |
229 | } | |
230 | ||
231 | # fetch the background color from a widget. | |
232 | proc get_bg_color {w} { | |
233 | global use_ttk | |
234 | if {$use_ttk} { | |
235 | set bg [ttk::style lookup [winfo class $w] -background] | |
236 | } else { | |
237 | set bg [$w cget -background] | |
238 | } | |
239 | return $bg | |
240 | } | |
241 | ||
242 | # ttk::spinbox didn't get added until 8.6 | |
243 | proc tspinbox {w args} { | |
244 | global use_ttk | |
245 | if {$use_ttk && [llength [info commands ttk::spinbox]] > 0} { | |
246 | eval [linsert $args 0 ttk::spinbox $w] | |
247 | } else { | |
248 | eval [linsert $args 0 spinbox $w] | |
249 | } | |
250 | } | |
251 | ||
30508bc4 PT |
252 | # Create a text widget with any theme specific properties. |
253 | proc ttext {w args} { | |
254 | global use_ttk | |
255 | if {$use_ttk} { | |
f50d5055 | 256 | switch -- [ttk_get_current_theme] { |
30508bc4 PT |
257 | "vista" - "xpnative" { |
258 | lappend args -highlightthickness 0 -borderwidth 0 | |
259 | } | |
260 | } | |
261 | } | |
262 | set w [eval [linsert $args 0 text $w]] | |
263 | if {$use_ttk} { | |
264 | if {[winfo class [winfo parent $w]] eq "EntryFrame"} { | |
265 | bind $w <FocusIn> {[winfo parent %W] state focus} | |
266 | bind $w <FocusOut> {[winfo parent %W] state !focus} | |
267 | } | |
268 | } | |
269 | return $w | |
270 | } | |
271 | ||
272 | # themed frame suitable for surrounding a text field. | |
273 | proc textframe {w args} { | |
274 | global use_ttk | |
275 | if {$use_ttk} { | |
276 | if {[catch {ttk::style layout EntryFrame}]} { | |
277 | InitEntryFrame | |
278 | } | |
279 | eval [linsert $args 0 ttk::frame $w -class EntryFrame -style EntryFrame] | |
280 | } else { | |
281 | eval [linsert $args 0 frame $w] | |
282 | } | |
283 | return $w | |
284 | } | |
285 | ||
35927672 PT |
286 | proc tentry {w args} { |
287 | global use_ttk | |
288 | if {$use_ttk} { | |
289 | InitTheme | |
290 | ttk::entry $w -style Edged.Entry | |
291 | } else { | |
292 | entry $w | |
293 | } | |
294 | ||
295 | rename $w _$w | |
296 | interp alias {} $w {} tentry_widgetproc $w | |
297 | eval [linsert $args 0 tentry_widgetproc $w configure] | |
298 | return $w | |
299 | } | |
300 | proc tentry_widgetproc {w cmd args} { | |
301 | global use_ttk | |
302 | switch -- $cmd { | |
303 | state { | |
304 | if {$use_ttk} { | |
305 | return [uplevel 1 [list _$w $cmd] $args] | |
306 | } else { | |
307 | if {[lsearch -exact $args pressed] != -1} { | |
308 | _$w configure -background lightpink | |
309 | } else { | |
310 | _$w configure -background lightgreen | |
311 | } | |
312 | } | |
313 | } | |
314 | configure { | |
315 | if {$use_ttk} { | |
316 | if {[set n [lsearch -exact $args -background]] != -1} { | |
317 | set args [lreplace $args $n [incr n]] | |
318 | if {[llength $args] == 0} {return} | |
319 | } | |
320 | } | |
321 | return [uplevel 1 [list _$w $cmd] $args] | |
322 | } | |
323 | default { return [uplevel 1 [list _$w $cmd] $args] } | |
324 | } | |
325 | } | |
326 | ||
c80d7be5 PT |
327 | # Tk 8.6 provides a standard font selection dialog. This uses the native |
328 | # dialogs on Windows and MacOSX or a standard Tk dialog on X11. | |
329 | proc tchoosefont {w title familyvar sizevar} { | |
330 | if {[package vsatisfies [package provide Tk] 8.6]} { | |
331 | upvar #0 $familyvar family | |
332 | upvar #0 $sizevar size | |
333 | tk fontchooser configure -parent $w -title $title \ | |
334 | -font [list $family $size] \ | |
335 | -command [list on_choosefont $familyvar $sizevar] | |
336 | tk fontchooser show | |
337 | } else { | |
338 | choose_font::pick $w $title $familyvar $sizevar | |
339 | } | |
340 | } | |
341 | ||
342 | # Called when the Tk 8.6 fontchooser selects a font. | |
343 | proc on_choosefont {familyvar sizevar font} { | |
344 | upvar #0 $familyvar family | |
345 | upvar #0 $sizevar size | |
346 | set font [font actual $font] | |
347 | set family [dict get $font -family] | |
348 | set size [dict get $font -size] | |
349 | } | |
350 | ||
351 | # Local variables: | |
352 | # mode: tcl | |
353 | # indent-tabs-mode: t | |
354 | # tab-width: 4 | |
355 | # End: |