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