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
  12         proc sync_with_theme {} {
  13                 set base_bg             [ttk::style lookup . -background]
  14                 set base_fg             [ttk::style lookup . -foreground]
  15                 set text_bg             [ttk::style lookup Treeview -background]
  16                 set text_fg             [ttk::style lookup Treeview -foreground]
  17                 set select_bg   [ttk::style lookup Default -selectbackground]
  18                 set select_fg   [ttk::style lookup Default -selectforeground]
  19
  20                 set color::select_bg $select_bg
  21                 set color::select_fg $select_fg
  22
  23                 proc add_option {key val} {
  24                         option add $key $val widgetDefault
  25                 }
  26                 # Add options for plain Tk widgets
  27                 # Using `option add` instead of tk_setPalette to avoid unintended
  28                 # consequences.
  29                 if {![is_MacOSX]} {
  30                         add_option *Menu.Background $base_bg
  31                         add_option *Menu.Foreground $base_fg
  32                         add_option *Menu.activeBackground $select_bg
  33                         add_option *Menu.activeForeground $select_fg
  34                 }
  35                 add_option *Text.Background $text_bg
  36                 add_option *Text.Foreground $text_fg
  37                 add_option *Text.selectBackground $select_bg
  38                 add_option *Text.selectForeground $select_fg
  39                 add_option *Text.inactiveSelectBackground $select_bg
  40                 add_option *Text.inactiveSelectForeground $select_fg
  41         }
  42 }
  43
  44 proc ttk_get_current_theme {} {
  45         # Handle either current Tk or older versions of 8.5
  46         if {[catch {set theme [ttk::style theme use]}]} {
  47                 set theme  $::ttk::currentTheme
  48         }
  49         return $theme
  50 }
  51
  52 proc InitTheme {} {
  53         # Create a color label style (bg can be overridden by widget option)
  54         ttk::style layout Color.TLabel {
  55                 Color.Label.border -sticky news -children {
  56                         Color.label.fill -sticky news -children {
  57                                 Color.Label.padding -sticky news -children {
  58                                         Color.Label.label -sticky news}}}}
  59         eval [linsert [ttk::style configure TLabel] 0 \
  60                           ttk::style configure Color.TLabel]
  61         ttk::style configure Color.TLabel \
  62                 -borderwidth 0 -relief flat -padding 2
  63         ttk::style map Color.TLabel -background {{} gold}
  64         # We also need a padded label.
  65         ttk::style configure Padded.TLabel \
  66                 -padding {5 5} -borderwidth 1 -relief solid
  67         # We need a gold frame.
  68         ttk::style layout Gold.TFrame {
  69                 Gold.Frame.border -sticky nswe -children {
  70                         Gold.Frame.fill -sticky nswe}}
  71         ttk::style configure Gold.TFrame -background gold -relief flat
  72         # listboxes should have a theme border so embed in ttk::frame
  73         ttk::style layout SListbox.TFrame {
  74                 SListbox.Frame.Entry.field -sticky news -border true -children {
  75                         SListbox.Frame.padding -sticky news
  76                 }
  77         }
  78
  79         set theme [ttk_get_current_theme]
  80
  81         if {[lsearch -exact {default alt classic clam} $theme] != -1} {
  82                 # Simple override of standard ttk::entry to change the field
  83                 # packground according to a state flag. We should use 'user1'
  84                 # but not all versions of 8.5 support that so make use of 'pressed'
  85                 # which is not normally in use for entry widgets.
  86                 ttk::style layout Edged.Entry [ttk::style layout TEntry]
  87                 ttk::style map Edged.Entry {*}[ttk::style map TEntry]
  88                 ttk::style configure Edged.Entry {*}[ttk::style configure TEntry] \
  89                         -fieldbackground lightgreen
  90                 ttk::style map Edged.Entry -fieldbackground {
  91                         {pressed !disabled} lightpink
  92                 }
  93         } else {
  94                 # For fancier themes, in particular the Windows ones, the field
  95                 # element may not support changing the background color. So instead
  96                 # override the fill using the default fill element. If we overrode
  97                 # the vista theme field element we would loose the themed border
  98                 # of the widget.
  99                 catch {
 100                         ttk::style element create color.fill from default
 101                 }
 102
 103                 ttk::style layout Edged.Entry {
 104                         Edged.Entry.field -sticky nswe -border 0 -children {
 105                                 Edged.Entry.border -sticky nswe -border 1 -children {
 106                                         Edged.Entry.padding -sticky nswe -children {
 107                                                 Edged.Entry.color.fill -sticky nswe -children {
 108                                                         Edged.Entry.textarea -sticky nswe
 109                                                 }
 110                                         }
 111                                 }
 112                         }
 113                 }
 114
 115                 ttk::style configure Edged.Entry {*}[ttk::style configure TEntry] \
 116                         -background lightgreen -padding 0 -borderwidth 0
 117                 ttk::style map Edged.Entry {*}[ttk::style map TEntry] \
 118                         -background {{pressed !disabled} lightpink}
 119         }
 120
 121         if {[lsearch [bind . <<ThemeChanged>>] InitTheme] == -1} {
 122                 bind . <<ThemeChanged>> +[namespace code [list InitTheme]]
 123         }
 124 }
 125
 126 # Define a style used for the surround of text widgets.
 127 proc InitEntryFrame {} {
 128         ttk::style theme settings default {
 129                 ttk::style layout EntryFrame {
 130                         EntryFrame.field -sticky nswe -border 0 -children {
 131                                 EntryFrame.fill -sticky nswe -children {
 132                                         EntryFrame.padding -sticky nswe
 133                                 }
 134                         }
 135                 }
 136                 ttk::style configure EntryFrame -padding 1 -relief sunken
 137                 ttk::style map EntryFrame -background {}
 138         }
 139         ttk::style theme settings classic {
 140                 ttk::style configure EntryFrame -padding 2 -relief sunken
 141                 ttk::style map EntryFrame -background {}
 142         }
 143         ttk::style theme settings alt {
 144                 ttk::style configure EntryFrame -padding 2
 145                 ttk::style map EntryFrame -background {}
 146         }
 147         ttk::style theme settings clam {
 148                 ttk::style configure EntryFrame -padding 2
 149                 ttk::style map EntryFrame -background {}
 150         }
 151
 152         # Ignore errors for missing native themes
 153         catch {
 154                 ttk::style theme settings winnative {
 155                         ttk::style configure EntryFrame -padding 2
 156                 }
 157                 ttk::style theme settings xpnative {
 158                         ttk::style configure EntryFrame -padding 1
 159                         ttk::style element create EntryFrame.field vsapi \
 160                                 EDIT 1 {disabled 4 focus 3 active 2 {} 1} -padding 1
 161                 }
 162                 ttk::style theme settings vista {
 163                         ttk::style configure EntryFrame -padding 2
 164                         ttk::style element create EntryFrame.field vsapi \
 165                                 EDIT 6 {disabled 4 focus 3 active 2 {} 1} -padding 2
 166                 }
 167         }
 168
 169         bind EntryFrame <Enter> {%W instate !disabled {%W state active}}
 170         bind EntryFrame <Leave> {%W state !active}
 171         bind EntryFrame <<ThemeChanged>> {
 172                 set pad [ttk::style lookup EntryFrame -padding]
 173                 %W configure -padding [expr {$pad eq {} ? 1 : $pad}]
 174         }
 175 }
 176
 177 proc gold_frame {w args} {
 178         global use_ttk
 179         if {$use_ttk && ![is_MacOSX]} {
 180                 eval [linsert $args 0 ttk::frame $w -style Gold.TFrame]
 181         } else {
 182                 eval [linsert $args 0 frame $w -background gold]
 183         }
 184 }
 185
 186 proc tlabel {w args} {
 187         global use_ttk
 188         if {$use_ttk && ![is_MacOSX]} {
 189                 set cmd [list ttk::label $w -style Color.TLabel]
 190                 foreach {k v} $args {
 191                         switch -glob -- $k {
 192                                 -activebackground {}
 193                                 default { lappend cmd $k $v }
 194                         }
 195                 }
 196                 eval $cmd
 197         } else {
 198                 eval [linsert $args 0 label $w]
 199         }
 200 }
 201
 202 # The padded label gets used in the about class.
 203 proc paddedlabel {w args} {
 204         global use_ttk
 205         if {$use_ttk} {
 206                 eval [linsert $args 0 ttk::label $w -style Padded.TLabel]
 207         } else {
 208                 eval [linsert $args 0 label $w \
 209                                   -padx 5 -pady 5 \
 210                                   -justify left \
 211                                   -anchor w \
 212                                   -borderwidth 1 \
 213                                   -relief solid]
 214         }
 215 }
 216
 217 # Create a toplevel for use as a dialog.
 218 # If available, sets the EWMH dialog hint and if ttk is enabled
 219 # place a themed frame over the surface.
 220 proc Dialog {w args} {
 221         eval [linsert $args 0 toplevel $w -class Dialog]
 222         catch {wm attributes $w -type dialog}
 223         pave_toplevel $w
 224         return $w
 225 }
 226
 227 # Tk toplevels are not themed - so pave it over with a themed frame to get
 228 # the base color correct per theme.
 229 proc pave_toplevel {w} {
 230         global use_ttk
 231         if {$use_ttk && ![winfo exists $w.!paving]} {
 232                 set paving [ttk::frame $w.!paving]
 233                 place $paving -x 0 -y 0 -relwidth 1 -relheight 1
 234                 lower $paving
 235         }
 236 }
 237
 238 # Create a scrolled listbox with appropriate border for the current theme.
 239 # On many themes the border for a scrolled listbox needs to go around the
 240 # listbox and the scrollbar.
 241 proc slistbox {w args} {
 242         global use_ttk NS
 243         if {$use_ttk} {
 244                 set f [ttk::frame $w -style SListbox.TFrame -padding 2]
 245         } else {
 246                 set f [frame $w -relief flat]
 247         }
 248     if {[catch {
 249                 if {$use_ttk} {
 250                         eval [linsert $args 0 listbox $f.list -relief flat \
 251                                           -highlightthickness 0 -borderwidth 0]
 252                 } else {
 253                         eval [linsert $args 0 listbox $f.list]
 254                 }
 255         ${NS}::scrollbar $f.vs -command [list $f.list yview]
 256         $f.list configure -yscrollcommand [list $f.vs set]
 257         grid $f.list $f.vs -sticky news
 258         grid rowconfigure $f 0 -weight 1
 259         grid columnconfigure $f 0 -weight 1
 260                 bind $f.list <<ListboxSelect>> \
 261                         [list event generate $w <<ListboxSelect>>]
 262         interp hide {} $w
 263         interp alias {} $w {} $f.list
 264     } err]} {
 265         destroy $f
 266         return -code error $err
 267     }
 268     return $w
 269 }
 270
 271 # fetch the background color from a widget.
 272 proc get_bg_color {w} {
 273         global use_ttk
 274         if {$use_ttk} {
 275                 set bg [ttk::style lookup [winfo class $w] -background]
 276         } else {
 277                 set bg [$w cget -background]
 278         }
 279         return $bg
 280 }
 281
 282 # ttk::spinbox didn't get added until 8.6
 283 proc tspinbox {w args} {
 284         global use_ttk
 285         if {$use_ttk && [llength [info commands ttk::spinbox]] > 0} {
 286                 eval [linsert $args 0 ttk::spinbox $w]
 287         } else {
 288                 eval [linsert $args 0 spinbox $w]
 289         }
 290 }
 291
 292 # Create a text widget with any theme specific properties.
 293 proc ttext {w args} {
 294         global use_ttk
 295         if {$use_ttk} {
 296                 switch -- [ttk_get_current_theme] {
 297                         "vista" - "xpnative" {
 298                                 lappend args -highlightthickness 0 -borderwidth 0
 299                         }
 300                 }
 301         }
 302         set w [eval [linsert $args 0 text $w]]
 303         if {$use_ttk} {
 304                 if {[winfo class [winfo parent $w]] eq "EntryFrame"} {
 305                         bind $w <FocusIn> {[winfo parent %W] state focus}
 306                         bind $w <FocusOut> {[winfo parent %W] state !focus}
 307                 }
 308         }
 309         return $w
 310 }
 311
 312 # themed frame suitable for surrounding a text field.
 313 proc textframe {w args} {
 314         global use_ttk
 315         if {$use_ttk} {
 316                 if {[catch {ttk::style layout EntryFrame}]} {
 317                         InitEntryFrame
 318                 }
 319                 eval [linsert $args 0 ttk::frame $w -class EntryFrame -style EntryFrame]
 320         } else {
 321                 eval [linsert $args 0 frame $w]
 322         }
 323         return $w
 324 }
 325
 326 proc tentry {w args} {
 327         global use_ttk
 328         if {$use_ttk} {
 329                 InitTheme
 330                 ttk::entry $w -style Edged.Entry
 331         } else {
 332                 entry $w
 333         }
 334
 335         rename $w _$w
 336         interp alias {} $w {} tentry_widgetproc $w
 337         eval [linsert $args 0 tentry_widgetproc $w configure]
 338         return $w
 339 }
 340 proc tentry_widgetproc {w cmd args} {
 341         global use_ttk
 342         switch -- $cmd {
 343                 state {
 344                         if {$use_ttk} {
 345                                 return [uplevel 1 [list _$w $cmd] $args]
 346                         } else {
 347                                 if {[lsearch -exact $args pressed] != -1} {
 348                                         _$w configure -background lightpink
 349                                 } else {
 350                                         _$w configure -background lightgreen
 351                                 }
 352                         }
 353                 }
 354                 configure {
 355                         if {$use_ttk} {
 356                                 if {[set n [lsearch -exact $args -background]] != -1} {
 357                                         set args [lreplace $args $n [incr n]]
 358                                         if {[llength $args] == 0} {return}
 359                                 }
 360                         }
 361                         return [uplevel 1 [list _$w $cmd] $args]
 362                 }
 363                 default { return [uplevel 1 [list _$w $cmd] $args] }
 364         }
 365 }
 366
 367 # Tk 8.6 provides a standard font selection dialog. This uses the native
 368 # dialogs on Windows and MacOSX or a standard Tk dialog on X11.
 369 proc tchoosefont {w title familyvar sizevar} {
 370         if {[package vsatisfies [package provide Tk] 8.6]} {
 371                 upvar #0 $familyvar family
 372                 upvar #0 $sizevar size
 373                 tk fontchooser configure -parent $w -title $title \
 374                         -font [list $family $size] \
 375                         -command [list on_choosefont $familyvar $sizevar]
 376                 tk fontchooser show
 377         } else {
 378                 choose_font::pick $w $title $familyvar $sizevar
 379         }
 380 }
 381
 382 # Called when the Tk 8.6 fontchooser selects a font.
 383 proc on_choosefont {familyvar sizevar font} {
 384         upvar #0 $familyvar family
 385         upvar #0 $sizevar size
 386         set font [font actual $font]
 387         set family [dict get $font -family]
 388         set size [dict get $font -size]
 389 }
 390
 391 # Local variables:
 392 # mode: tcl
 393 # indent-tabs-mode: t
 394 # tab-width: 4
 395 # End: