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