| 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 | |
| 5 | namespace 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 | |
| 50 | proc 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 | |
| 59 | proc 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 | |
| 67 | proc 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. |
| 142 | proc 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 | |
| 192 | proc 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 | |
| 200 | proc 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. |
| 216 | proc 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. |
| 223 | proc 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. |
| 232 | proc 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. |
| 243 | proc 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. |
| 265 | proc get_bg_color {w} { |
| 266 | set bg [ttk::style lookup [winfo class $w] -background] |
| 267 | return $bg |
| 268 | } |
| 269 | |
| 270 | # ttk::spinbox |
| 271 | proc tspinbox {w args} { |
| 272 | eval [linsert $args 0 ttk::spinbox $w] |
| 273 | } |
| 274 | |
| 275 | # Create a text widget with any theme specific properties. |
| 276 | proc 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. |
| 291 | proc 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 | |
| 299 | proc 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 | } |
| 308 | proc 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. |
| 326 | proc 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. |
| 340 | proc 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: |