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