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 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
  32 proc gold_frame {w args} {
  33         global use_ttk
  34         if {$use_ttk} {
  35                 eval [linsert $args 0 ttk::frame $w -style Gold.TFrame]
  36         } else {
  37                 eval [linsert $args 0 frame $w -background gold]
  38         }
  39 }
  40
  41 proc tlabel {w args} {
  42         global use_ttk
  43         if {$use_ttk} {
  44                 set cmd [list ttk::label $w -style Color.TLabel]
  45                 foreach {k v} $args {
  46                         switch -glob -- $k {
  47                                 -activebackground {}
  48                                 default { lappend cmd $k $v }
  49                         }
  50                 }
  51                 eval $cmd
  52         } else {
  53                 eval [linsert $args 0 label $w]
  54         }
  55 }
  56
  57 # The padded label gets used in the about class.
  58 proc paddedlabel {w args} {
  59         global use_ttk
  60         if {$use_ttk} {
  61                 eval [linsert $args 0 ttk::label $w -style Padded.TLabel]
  62         } else {
  63                 eval [linsert $args 0 label $w \
  64                                   -padx 5 -pady 5 \
  65                                   -justify left \
  66                                   -anchor w \
  67                                   -borderwidth 1 \
  68                                   -relief solid]
  69         }
  70 }
  71
  72 # Create a toplevel for use as a dialog.
  73 # If available, sets the EWMH dialog hint and if ttk is enabled
  74 # place a themed frame over the surface.
  75 proc Dialog {w args} {
  76         eval [linsert $args 0 toplevel $w -class Dialog]
  77         pave_toplevel $w
  78         return $w
  79 }
  80
  81 # Tk toplevels are not themed - so pave it over with a themed frame to get
  82 # the base color correct per theme.
  83 proc pave_toplevel {w} {
  84         global use_ttk
  85         if {$use_ttk && ![winfo exists $w.!paving]} {
  86                 set paving [ttk::frame $w.!paving]
  87                 place $paving -x 0 -y 0 -relwidth 1 -relheight 1
  88                 lower $paving
  89         }
  90 }
  91
  92 # Create a scrolled listbox with appropriate border for the current theme.
  93 # On many themes the border for a scrolled listbox needs to go around the
  94 # listbox and the scrollbar.
  95 proc slistbox {w args} {
  96         global use_ttk NS
  97         if {$use_ttk} {
  98                 set f [ttk::frame $w -style SListbox.TFrame -padding 2]
  99         } else {
 100                 set f [frame $w -relief flat]
 101         }
 102     if {[catch {
 103                 if {$use_ttk} {
 104                         eval [linsert $args 0 listbox $f.list -relief flat \
 105                                           -highlightthickness 0 -borderwidth 0]
 106                 } else {
 107                         eval [linsert $args 0 listbox $f.list]
 108                 }
 109         ${NS}::scrollbar $f.vs -command [list $f.list yview]
 110         $f.list configure -yscrollcommand [list $f.vs set]
 111         grid $f.list $f.vs -sticky news
 112         grid rowconfigure $f 0 -weight 1
 113         grid columnconfigure $f 0 -weight 1
 114                 bind $f.list <<ListboxSelect>> \
 115                         [list event generate $w <<ListboxSelect>>]
 116         interp hide {} $w
 117         interp alias {} $w {} $f.list
 118     } err]} {
 119         destroy $f
 120         return -code error $err
 121     }
 122     return $w
 123 }
 124
 125 # fetch the background color from a widget.
 126 proc get_bg_color {w} {
 127         global use_ttk
 128         if {$use_ttk} {
 129                 set bg [ttk::style lookup [winfo class $w] -background]
 130         } else {
 131                 set bg [$w cget -background]
 132         }
 133         return $bg
 134 }
 135
 136 # ttk::spinbox didn't get added until 8.6
 137 proc tspinbox {w args} {
 138         global use_ttk
 139         if {$use_ttk && [llength [info commands ttk::spinbox]] > 0} {
 140                 eval [linsert $args 0 ttk::spinbox $w]
 141         } else {
 142                 eval [linsert $args 0 spinbox $w]
 143         }
 144 }
 145
 146 # Tk 8.6 provides a standard font selection dialog. This uses the native
 147 # dialogs on Windows and MacOSX or a standard Tk dialog on X11.
 148 proc tchoosefont {w title familyvar sizevar} {
 149         if {[package vsatisfies [package provide Tk] 8.6]} {
 150                 upvar #0 $familyvar family
 151                 upvar #0 $sizevar size
 152                 tk fontchooser configure -parent $w -title $title \
 153                         -font [list $family $size] \
 154                         -command [list on_choosefont $familyvar $sizevar]
 155                 tk fontchooser show
 156         } else {
 157                 choose_font::pick $w $title $familyvar $sizevar
 158         }
 159 }
 160
 161 # Called when the Tk 8.6 fontchooser selects a font.
 162 proc on_choosefont {familyvar sizevar font} {
 163         upvar #0 $familyvar family
 164         upvar #0 $sizevar size
 165         set font [font actual $font]
 166         set family [dict get $font -family]
 167         set size [dict get $font -size]
 168 }
 169
 170 # Local variables:
 171 # mode: tcl
 172 # indent-tabs-mode: t
 173 # tab-width: 4
 174 # End: