Merge branch 'en/rerere-multi-stage-1-fix' into maint
[git] / git-gui / lib / themed.tcl
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 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
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 {
34                 SListbox.Frame.Entry.field -sticky news -border true -children {
35                         SListbox.Frame.padding -sticky news
36                 }
37         }
38
39         set theme [ttk_get_current_theme]
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         }
84 }
85
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
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]
182         catch {wm attributes $w -type dialog}
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
252 # Create a text widget with any theme specific properties.
253 proc ttext {w args} {
254         global use_ttk
255         if {$use_ttk} {
256                 switch -- [ttk_get_current_theme] {
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
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
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: