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