Merge branch 'jc/maint-log-first-parent-pathspec' 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 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
31         # 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
36         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
58                 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
70                 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
76         if {[lsearch [bind . <<ThemeChanged>>] InitTheme] == -1} {
77                 bind . <<ThemeChanged>> +[namespace code [list InitTheme]]
78         }
79 }
80
81 proc 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 }
89
90 proc 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
106 # The padded label gets used in the about class.
107 proc 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
121 # 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.
124 proc Dialog {w args} {
125         eval [linsert $args 0 toplevel $w -class Dialog]
126         catch {wm attributes $w -type dialog}   
127         pave_toplevel $w
128         return $w
129 }
130
131 # Tk toplevels are not themed - so pave it over with a themed frame to get
132 # the base color correct per theme.
133 proc pave_toplevel {w} {
134         global use_ttk
135         if {$use_ttk && ![winfo exists $w.!paving]} {
136                 set paving [ttk::frame $w.!paving]
137                 place $paving -x 0 -y 0 -relwidth 1 -relheight 1
138                 lower $paving
139         }
140 }
141
142 # Create a scrolled listbox with appropriate border for the current theme.
143 # On many themes the border for a scrolled listbox needs to go around the
144 # listbox and the scrollbar.
145 proc slistbox {w args} {
146         global use_ttk NS
147         if {$use_ttk} {
148                 set f [ttk::frame $w -style SListbox.TFrame -padding 2]
149         } else {
150                 set f [frame $w -relief flat]
151         }
152     if {[catch {
153                 if {$use_ttk} {
154                         eval [linsert $args 0 listbox $f.list -relief flat \
155                                           -highlightthickness 0 -borderwidth 0]
156                 } else {
157                         eval [linsert $args 0 listbox $f.list]
158                 }
159         ${NS}::scrollbar $f.vs -command [list $f.list yview]
160         $f.list configure -yscrollcommand [list $f.vs set]
161         grid $f.list $f.vs -sticky news
162         grid rowconfigure $f 0 -weight 1
163         grid columnconfigure $f 0 -weight 1
164                 bind $f.list <<ListboxSelect>> \
165                         [list event generate $w <<ListboxSelect>>]
166         interp hide {} $w
167         interp alias {} $w {} $f.list
168     } err]} {
169         destroy $f
170         return -code error $err
171     }
172     return $w
173 }
174
175 # fetch the background color from a widget.
176 proc get_bg_color {w} {
177         global use_ttk
178         if {$use_ttk} {
179                 set bg [ttk::style lookup [winfo class $w] -background]
180         } else {
181                 set bg [$w cget -background]
182         }
183         return $bg
184 }
185
186 # ttk::spinbox didn't get added until 8.6
187 proc tspinbox {w args} {
188         global use_ttk
189         if {$use_ttk && [llength [info commands ttk::spinbox]] > 0} {
190                 eval [linsert $args 0 ttk::spinbox $w]
191         } else {
192                 eval [linsert $args 0 spinbox $w]
193         }
194 }
195
196 proc tentry {w args} {
197         global use_ttk
198         if {$use_ttk} {
199                 InitTheme
200                 ttk::entry $w -style Edged.Entry
201         } else {
202                 entry $w
203         }
204
205         rename $w _$w
206         interp alias {} $w {} tentry_widgetproc $w
207         eval [linsert $args 0 tentry_widgetproc $w configure]
208         return $w
209 }
210 proc tentry_widgetproc {w cmd args} {
211         global use_ttk
212         switch -- $cmd {
213                 state {
214                         if {$use_ttk} {
215                                 return [uplevel 1 [list _$w $cmd] $args]
216                         } else {
217                                 if {[lsearch -exact $args pressed] != -1} {
218                                         _$w configure -background lightpink
219                                 } else {
220                                         _$w configure -background lightgreen
221                                 }
222                         }
223                 }
224                 configure {
225                         if {$use_ttk} {
226                                 if {[set n [lsearch -exact $args -background]] != -1} {
227                                         set args [lreplace $args $n [incr n]]
228                                         if {[llength $args] == 0} {return}
229                                 }
230                         }
231                         return [uplevel 1 [list _$w $cmd] $args]
232                 }
233                 default { return [uplevel 1 [list _$w $cmd] $args] }
234         }
235 }
236
237 # Tk 8.6 provides a standard font selection dialog. This uses the native
238 # dialogs on Windows and MacOSX or a standard Tk dialog on X11.
239 proc tchoosefont {w title familyvar sizevar} {
240         if {[package vsatisfies [package provide Tk] 8.6]} {
241                 upvar #0 $familyvar family
242                 upvar #0 $sizevar size
243                 tk fontchooser configure -parent $w -title $title \
244                         -font [list $family $size] \
245                         -command [list on_choosefont $familyvar $sizevar]
246                 tk fontchooser show
247         } else {
248                 choose_font::pick $w $title $familyvar $sizevar
249         }
250 }
251
252 # Called when the Tk 8.6 fontchooser selects a font.
253 proc on_choosefont {familyvar sizevar font} {
254         upvar #0 $familyvar family
255         upvar #0 $sizevar size
256         set font [font actual $font]
257         set family [dict get $font -family]
258         set size [dict get $font -size]
259 }
260
261 # Local variables:
262 # mode: tcl
263 # indent-tabs-mode: t
264 # tab-width: 4
265 # End: