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         pave_toplevel $w
 127         return $w
 128 }
 129
 130 # Tk toplevels are not themed - so pave it over with a themed frame to get
 131 # the base color correct per theme.
 132 proc 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
 141 # 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.
 144 proc 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
 174 # fetch the background color from a widget.
 175 proc 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
 185 # ttk::spinbox didn't get added until 8.6
 186 proc 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 }
 194
 195 proc 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
 204         rename $w _$w
 205         interp alias {} $w {} tentry_widgetproc $w
 206         eval [linsert $args 0 tentry_widgetproc $w configure]
 207         return $w
 208 }
 209 proc 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
 236 # 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.
 238 proc 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
 251 # Called when the Tk 8.6 fontchooser selects a font.
 252 proc 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
 260 # Local variables:
 261 # mode: tcl
 262 # indent-tabs-mode: t
 263 # tab-width: 4
 264 # End: