29a1696d9707ec588680053248b135bca7606220
1# Functions for supporting the use of themed Tk widgets in git-gui.
2# Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
3proc InitTheme {} {
5 # Create a color label style (bg can be overridden by widget option)
6 ttk::style layout Color.TLabel {
7 Color.Label.border -sticky news -children {
8 Color.label.fill -sticky news -children {
9 Color.Label.padding -sticky news -children {
10 Color.Label.label -sticky news}}}}
11 eval [linsert [ttk::style configure TLabel] 0 \
12 ttk::style configure Color.TLabel]
13 ttk::style configure Color.TLabel \
14 -borderwidth 0 -relief flat -padding 2
15 ttk::style map Color.TLabel -background {{} gold}
16 # We also need a padded label.
17 ttk::style configure Padded.TLabel \
18 -padding {5 5} -borderwidth 1 -relief solid
19 # We need a gold frame.
20 ttk::style layout Gold.TFrame {
21 Gold.Frame.border -sticky nswe -children {
22 Gold.Frame.fill -sticky nswe}}
23 ttk::style configure Gold.TFrame -background gold -relief flat
24 # listboxes should have a theme border so embed in ttk::frame
25 ttk::style layout SListbox.TFrame {
26 SListbox.Frame.Entry.field -sticky news -border true -children {
27 SListbox.Frame.padding -sticky news
28 }
29 }
30 # Handle either current Tk or older versions of 8.5
32 if {[catch {set theme [ttk::style theme use]}]} {
33 set theme $::ttk::currentTheme
34 }
35 if {[lsearch -exact {default alt classic clam} $theme] != -1} {
37 # Simple override of standard ttk::entry to change the field
38 # packground according to a state flag. We should use 'user1'
39 # but not all versions of 8.5 support that so make use of 'pressed'
40 # which is not normally in use for entry widgets.
41 ttk::style layout Edged.Entry [ttk::style layout TEntry]
42 ttk::style map Edged.Entry {*}[ttk::style map TEntry]
43 ttk::style configure Edged.Entry {*}[ttk::style configure TEntry] \
44 -fieldbackground lightgreen
45 ttk::style map Edged.Entry -fieldbackground {
46 {pressed !disabled} lightpink
47 }
48 } else {
49 # For fancier themes, in particular the Windows ones, the field
50 # element may not support changing the background color. So instead
51 # override the fill using the default fill element. If we overrode
52 # the vista theme field element we would loose the themed border
53 # of the widget.
54 catch {
55 ttk::style element create color.fill from default
56 }
57 ttk::style layout Edged.Entry {
59 Edged.Entry.field -sticky nswe -border 0 -children {
60 Edged.Entry.border -sticky nswe -border 1 -children {
61 Edged.Entry.padding -sticky nswe -children {
62 Edged.Entry.color.fill -sticky nswe -children {
63 Edged.Entry.textarea -sticky nswe
64 }
65 }
66 }
67 }
68 }
69 ttk::style configure Edged.Entry {*}[ttk::style configure TEntry] \
71 -background lightgreen -padding 0 -borderwidth 0
72 ttk::style map Edged.Entry {*}[ttk::style map TEntry] \
73 -background {{pressed !disabled} lightpink}
74 }
75 if {[lsearch [bind . <<ThemeChanged>>] InitTheme] == -1} {
77 bind . <<ThemeChanged>> +[namespace code [list InitTheme]]
78 }
79}
80proc gold_frame {w args} {
82 global use_ttk
83 if {$use_ttk} {
84 eval [linsert $args 0 ttk::frame $w -style Gold.TFrame]
85 } else {
86 eval [linsert $args 0 frame $w -background gold]
87 }
88}
89proc tlabel {w args} {
91 global use_ttk
92 if {$use_ttk} {
93 set cmd [list ttk::label $w -style Color.TLabel]
94 foreach {k v} $args {
95 switch -glob -- $k {
96 -activebackground {}
97 default { lappend cmd $k $v }
98 }
99 }
100 eval $cmd
101 } else {
102 eval [linsert $args 0 label $w]
103 }
104}
105# The padded label gets used in the about class.
107proc paddedlabel {w args} {
108 global use_ttk
109 if {$use_ttk} {
110 eval [linsert $args 0 ttk::label $w -style Padded.TLabel]
111 } else {
112 eval [linsert $args 0 label $w \
113 -padx 5 -pady 5 \
114 -justify left \
115 -anchor w \
116 -borderwidth 1 \
117 -relief solid]
118 }
119}
120# Create a toplevel for use as a dialog.
122# If available, sets the EWMH dialog hint and if ttk is enabled
123# place a themed frame over the surface.
124proc Dialog {w args} {
125 eval [linsert $args 0 toplevel $w -class Dialog]
126 pave_toplevel $w
127 return $w
128}
129# Tk toplevels are not themed - so pave it over with a themed frame to get
131# the base color correct per theme.
132proc pave_toplevel {w} {
133 global use_ttk
134 if {$use_ttk && ![winfo exists $w.!paving]} {
135 set paving [ttk::frame $w.!paving]
136 place $paving -x 0 -y 0 -relwidth 1 -relheight 1
137 lower $paving
138 }
139}
140# Create a scrolled listbox with appropriate border for the current theme.
142# On many themes the border for a scrolled listbox needs to go around the
143# listbox and the scrollbar.
144proc slistbox {w args} {
145 global use_ttk NS
146 if {$use_ttk} {
147 set f [ttk::frame $w -style SListbox.TFrame -padding 2]
148 } else {
149 set f [frame $w -relief flat]
150 }
151 if {[catch {
152 if {$use_ttk} {
153 eval [linsert $args 0 listbox $f.list -relief flat \
154 -highlightthickness 0 -borderwidth 0]
155 } else {
156 eval [linsert $args 0 listbox $f.list]
157 }
158 ${NS}::scrollbar $f.vs -command [list $f.list yview]
159 $f.list configure -yscrollcommand [list $f.vs set]
160 grid $f.list $f.vs -sticky news
161 grid rowconfigure $f 0 -weight 1
162 grid columnconfigure $f 0 -weight 1
163 bind $f.list <<ListboxSelect>> \
164 [list event generate $w <<ListboxSelect>>]
165 interp hide {} $w
166 interp alias {} $w {} $f.list
167 } err]} {
168 destroy $f
169 return -code error $err
170 }
171 return $w
172}
173# fetch the background color from a widget.
175proc get_bg_color {w} {
176 global use_ttk
177 if {$use_ttk} {
178 set bg [ttk::style lookup [winfo class $w] -background]
179 } else {
180 set bg [$w cget -background]
181 }
182 return $bg
183}
184# ttk::spinbox didn't get added until 8.6
186proc tspinbox {w args} {
187 global use_ttk
188 if {$use_ttk && [llength [info commands ttk::spinbox]] > 0} {
189 eval [linsert $args 0 ttk::spinbox $w]
190 } else {
191 eval [linsert $args 0 spinbox $w]
192 }
193}
194proc tentry {w args} {
196 global use_ttk
197 if {$use_ttk} {
198 InitTheme
199 ttk::entry $w -style Edged.Entry
200 } else {
201 entry $w
202 }
203 rename $w _$w
205 interp alias {} $w {} tentry_widgetproc $w
206 eval [linsert $args 0 tentry_widgetproc $w configure]
207 return $w
208}
209proc tentry_widgetproc {w cmd args} {
210 global use_ttk
211 switch -- $cmd {
212 state {
213 if {$use_ttk} {
214 return [uplevel 1 [list _$w $cmd] $args]
215 } else {
216 if {[lsearch -exact $args pressed] != -1} {
217 _$w configure -background lightpink
218 } else {
219 _$w configure -background lightgreen
220 }
221 }
222 }
223 configure {
224 if {$use_ttk} {
225 if {[set n [lsearch -exact $args -background]] != -1} {
226 set args [lreplace $args $n [incr n]]
227 if {[llength $args] == 0} {return}
228 }
229 }
230 return [uplevel 1 [list _$w $cmd] $args]
231 }
232 default { return [uplevel 1 [list _$w $cmd] $args] }
233 }
234}
235# Tk 8.6 provides a standard font selection dialog. This uses the native
237# dialogs on Windows and MacOSX or a standard Tk dialog on X11.
238proc tchoosefont {w title familyvar sizevar} {
239 if {[package vsatisfies [package provide Tk] 8.6]} {
240 upvar #0 $familyvar family
241 upvar #0 $sizevar size
242 tk fontchooser configure -parent $w -title $title \
243 -font [list $family $size] \
244 -command [list on_choosefont $familyvar $sizevar]
245 tk fontchooser show
246 } else {
247 choose_font::pick $w $title $familyvar $sizevar
248 }
249}
250# Called when the Tk 8.6 fontchooser selects a font.
252proc on_choosefont {familyvar sizevar font} {
253 upvar #0 $familyvar family
254 upvar #0 $sizevar size
255 set font [font actual $font]
256 set family [dict get $font -family]
257 set size [dict get $font -size]
258}
259# Local variables:
261# mode: tcl
262# indent-tabs-mode: t
263# tab-width: 4
264# End: