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
   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         global use_ttk
 194         if {$use_ttk && ![is_MacOSX]} {
 195                 eval [linsert $args 0 ttk::frame $w -style Gold.TFrame]
 196         } else {
 197                 eval [linsert $args 0 frame $w -background gold]
 198         }
 199 }
 200
 201 proc tlabel {w args} {
 202         global use_ttk
 203         if {$use_ttk && ![is_MacOSX]} {
 204                 set cmd [list ttk::label $w -style Color.TLabel]
 205                 foreach {k v} $args {
 206                         switch -glob -- $k {
 207                                 -activebackground {}
 208                                 default { lappend cmd $k $v }
 209                         }
 210                 }
 211                 eval $cmd
 212         } else {
 213                 eval [linsert $args 0 label $w]
 214         }
 215 }
 216
 217 # The padded label gets used in the about class.
 218 proc paddedlabel {w args} {
 219         global use_ttk
 220         if {$use_ttk} {
 221                 eval [linsert $args 0 ttk::label $w -style Padded.TLabel]
 222         } else {
 223                 eval [linsert $args 0 label $w \
 224                                   -padx 5 -pady 5 \
 225                                   -justify left \
 226                                   -anchor w \
 227                                   -borderwidth 1 \
 228                                   -relief solid]
 229         }
 230 }
 231
 232 # Create a toplevel for use as a dialog.
 233 # If available, sets the EWMH dialog hint and if ttk is enabled
 234 # place a themed frame over the surface.
 235 proc Dialog {w args} {
 236         eval [linsert $args 0 toplevel $w -class Dialog]
 237         catch {wm attributes $w -type dialog}
 238         pave_toplevel $w
 239         return $w
 240 }
 241
 242 # Tk toplevels are not themed - so pave it over with a themed frame to get
 243 # the base color correct per theme.
 244 proc pave_toplevel {w} {
 245         global use_ttk
 246         if {$use_ttk && ![winfo exists $w.!paving]} {
 247                 set paving [ttk::frame $w.!paving]
 248                 place $paving -x 0 -y 0 -relwidth 1 -relheight 1
 249                 lower $paving
 250         }
 251 }
 252
 253 # Create a scrolled listbox with appropriate border for the current theme.
 254 # On many themes the border for a scrolled listbox needs to go around the
 255 # listbox and the scrollbar.
 256 proc slistbox {w args} {
 257         global use_ttk NS
 258         if {$use_ttk} {
 259                 set f [ttk::frame $w -style SListbox.TFrame -padding 2]
 260         } else {
 261                 set f [frame $w -relief flat]
 262         }
 263     if {[catch {
 264                 if {$use_ttk} {
 265                         eval [linsert $args 0 listbox $f.list -relief flat \
 266                                           -highlightthickness 0 -borderwidth 0]
 267                 } else {
 268                         eval [linsert $args 0 listbox $f.list]
 269                 }
 270         ${NS}::scrollbar $f.vs -command [list $f.list yview]
 271         $f.list configure -yscrollcommand [list $f.vs set]
 272         grid $f.list $f.vs -sticky news
 273         grid rowconfigure $f 0 -weight 1
 274         grid columnconfigure $f 0 -weight 1
 275                 bind $f.list <<ListboxSelect>> \
 276                         [list event generate $w <<ListboxSelect>>]
 277         interp hide {} $w
 278         interp alias {} $w {} $f.list
 279     } err]} {
 280         destroy $f
 281         return -code error $err
 282     }
 283     return $w
 284 }
 285
 286 # fetch the background color from a widget.
 287 proc get_bg_color {w} {
 288         global use_ttk
 289         if {$use_ttk} {
 290                 set bg [ttk::style lookup [winfo class $w] -background]
 291         } else {
 292                 set bg [$w cget -background]
 293         }
 294         return $bg
 295 }
 296
 297 # ttk::spinbox didn't get added until 8.6
 298 proc tspinbox {w args} {
 299         global use_ttk
 300         if {$use_ttk && [llength [info commands ttk::spinbox]] > 0} {
 301                 eval [linsert $args 0 ttk::spinbox $w]
 302         } else {
 303                 eval [linsert $args 0 spinbox $w]
 304         }
 305 }
 306
 307 # Create a text widget with any theme specific properties.
 308 proc ttext {w args} {
 309         global use_ttk
 310         if {$use_ttk} {
 311                 switch -- [ttk_get_current_theme] {
 312                         "vista" - "xpnative" {
 313                                 lappend args -highlightthickness 0 -borderwidth 0
 314                         }
 315                 }
 316         }
 317         set w [eval [linsert $args 0 text $w]]
 318         if {$use_ttk} {
 319                 if {[winfo class [winfo parent $w]] eq "EntryFrame"} {
 320                         bind $w <FocusIn> {[winfo parent %W] state focus}
 321                         bind $w <FocusOut> {[winfo parent %W] state !focus}
 322                 }
 323         }
 324         return $w
 325 }
 326
 327 # themed frame suitable for surrounding a text field.
 328 proc textframe {w args} {
 329         global use_ttk
 330         if {$use_ttk} {
 331                 if {[catch {ttk::style layout EntryFrame}]} {
 332                         InitEntryFrame
 333                 }
 334                 eval [linsert $args 0 ttk::frame $w -class EntryFrame -style EntryFrame]
 335         } else {
 336                 eval [linsert $args 0 frame $w]
 337         }
 338         return $w
 339 }
 340
 341 proc tentry {w args} {
 342         global use_ttk
 343         if {$use_ttk} {
 344                 InitTheme
 345                 ttk::entry $w -style Edged.Entry
 346         } else {
 347                 entry $w
 348         }
 349
 350         rename $w _$w
 351         interp alias {} $w {} tentry_widgetproc $w
 352         eval [linsert $args 0 tentry_widgetproc $w configure]
 353         return $w
 354 }
 355 proc tentry_widgetproc {w cmd args} {
 356         global use_ttk
 357         switch -- $cmd {
 358                 state {
 359                         if {$use_ttk} {
 360                                 return [uplevel 1 [list _$w $cmd] $args]
 361                         } else {
 362                                 if {[lsearch -exact $args pressed] != -1} {
 363                                         _$w configure -background lightpink
 364                                 } else {
 365                                         _$w configure -background lightgreen
 366                                 }
 367                         }
 368                 }
 369                 configure {
 370                         if {$use_ttk} {
 371                                 if {[set n [lsearch -exact $args -background]] != -1} {
 372                                         set args [lreplace $args $n [incr n]]
 373                                         if {[llength $args] == 0} {return}
 374                                 }
 375                         }
 376                         return [uplevel 1 [list _$w $cmd] $args]
 377                 }
 378                 default { return [uplevel 1 [list _$w $cmd] $args] }
 379         }
 380 }
 381
 382 # Tk 8.6 provides a standard font selection dialog. This uses the native
 383 # dialogs on Windows and MacOSX or a standard Tk dialog on X11.
 384 proc tchoosefont {w title familyvar sizevar} {
 385         if {[package vsatisfies [package provide Tk] 8.6]} {
 386                 upvar #0 $familyvar family
 387                 upvar #0 $sizevar size
 388                 tk fontchooser configure -parent $w -title $title \
 389                         -font [list $family $size] \
 390                         -command [list on_choosefont $familyvar $sizevar]
 391                 tk fontchooser show
 392         } else {
 393                 choose_font::pick $w $title $familyvar $sizevar
 394         }
 395 }
 396
 397 # Called when the Tk 8.6 fontchooser selects a font.
 398 proc on_choosefont {familyvar sizevar font} {
 399         upvar #0 $familyvar family
 400         upvar #0 $sizevar size
 401         set font [font actual $font]
 402         set family [dict get $font -family]
 403         set size [dict get $font -size]
 404 }
 405
 406 # Local variables:
 407 # mode: tcl
 408 # indent-tabs-mode: t
 409 # tab-width: 4
 410 # End: