| # Functions for supporting the use of themed Tk widgets in git-gui. |
| # Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net> |
| |
| proc ttk_get_current_theme {} { |
| # Handle either current Tk or older versions of 8.5 |
| if {[catch {set theme [ttk::style theme use]}]} { |
| set theme $::ttk::currentTheme |
| } |
| return $theme |
| } |
| |
| proc InitTheme {} { |
| # Create a color label style (bg can be overridden by widget option) |
| ttk::style layout Color.TLabel { |
| Color.Label.border -sticky news -children { |
| Color.label.fill -sticky news -children { |
| Color.Label.padding -sticky news -children { |
| Color.Label.label -sticky news}}}} |
| eval [linsert [ttk::style configure TLabel] 0 \ |
| ttk::style configure Color.TLabel] |
| ttk::style configure Color.TLabel \ |
| -borderwidth 0 -relief flat -padding 2 |
| ttk::style map Color.TLabel -background {{} gold} |
| # We also need a padded label. |
| ttk::style configure Padded.TLabel \ |
| -padding {5 5} -borderwidth 1 -relief solid |
| # We need a gold frame. |
| ttk::style layout Gold.TFrame { |
| Gold.Frame.border -sticky nswe -children { |
| Gold.Frame.fill -sticky nswe}} |
| ttk::style configure Gold.TFrame -background gold -relief flat |
| # listboxes should have a theme border so embed in ttk::frame |
| ttk::style layout SListbox.TFrame { |
| SListbox.Frame.Entry.field -sticky news -border true -children { |
| SListbox.Frame.padding -sticky news |
| } |
| } |
| |
| set theme [ttk_get_current_theme] |
| |
| if {[lsearch -exact {default alt classic clam} $theme] != -1} { |
| # Simple override of standard ttk::entry to change the field |
| # packground according to a state flag. We should use 'user1' |
| # but not all versions of 8.5 support that so make use of 'pressed' |
| # which is not normally in use for entry widgets. |
| ttk::style layout Edged.Entry [ttk::style layout TEntry] |
| ttk::style map Edged.Entry {*}[ttk::style map TEntry] |
| ttk::style configure Edged.Entry {*}[ttk::style configure TEntry] \ |
| -fieldbackground lightgreen |
| ttk::style map Edged.Entry -fieldbackground { |
| {pressed !disabled} lightpink |
| } |
| } else { |
| # For fancier themes, in particular the Windows ones, the field |
| # element may not support changing the background color. So instead |
| # override the fill using the default fill element. If we overrode |
| # the vista theme field element we would loose the themed border |
| # of the widget. |
| catch { |
| ttk::style element create color.fill from default |
| } |
| |
| ttk::style layout Edged.Entry { |
| Edged.Entry.field -sticky nswe -border 0 -children { |
| Edged.Entry.border -sticky nswe -border 1 -children { |
| Edged.Entry.padding -sticky nswe -children { |
| Edged.Entry.color.fill -sticky nswe -children { |
| Edged.Entry.textarea -sticky nswe |
| } |
| } |
| } |
| } |
| } |
| |
| ttk::style configure Edged.Entry {*}[ttk::style configure TEntry] \ |
| -background lightgreen -padding 0 -borderwidth 0 |
| ttk::style map Edged.Entry {*}[ttk::style map TEntry] \ |
| -background {{pressed !disabled} lightpink} |
| } |
| |
| if {[lsearch [bind . <<ThemeChanged>>] InitTheme] == -1} { |
| bind . <<ThemeChanged>> +[namespace code [list InitTheme]] |
| } |
| } |
| |
| # Define a style used for the surround of text widgets. |
| proc InitEntryFrame {} { |
| ttk::style theme settings default { |
| ttk::style layout EntryFrame { |
| EntryFrame.field -sticky nswe -border 0 -children { |
| EntryFrame.fill -sticky nswe -children { |
| EntryFrame.padding -sticky nswe |
| } |
| } |
| } |
| ttk::style configure EntryFrame -padding 1 -relief sunken |
| ttk::style map EntryFrame -background {} |
| } |
| ttk::style theme settings classic { |
| ttk::style configure EntryFrame -padding 2 -relief sunken |
| ttk::style map EntryFrame -background {} |
| } |
| ttk::style theme settings alt { |
| ttk::style configure EntryFrame -padding 2 |
| ttk::style map EntryFrame -background {} |
| } |
| ttk::style theme settings clam { |
| ttk::style configure EntryFrame -padding 2 |
| ttk::style map EntryFrame -background {} |
| } |
| |
| # Ignore errors for missing native themes |
| catch { |
| ttk::style theme settings winnative { |
| ttk::style configure EntryFrame -padding 2 |
| } |
| ttk::style theme settings xpnative { |
| ttk::style configure EntryFrame -padding 1 |
| ttk::style element create EntryFrame.field vsapi \ |
| EDIT 1 {disabled 4 focus 3 active 2 {} 1} -padding 1 |
| } |
| ttk::style theme settings vista { |
| ttk::style configure EntryFrame -padding 2 |
| ttk::style element create EntryFrame.field vsapi \ |
| EDIT 6 {disabled 4 focus 3 active 2 {} 1} -padding 2 |
| } |
| } |
| |
| bind EntryFrame <Enter> {%W instate !disabled {%W state active}} |
| bind EntryFrame <Leave> {%W state !active} |
| bind EntryFrame <<ThemeChanged>> { |
| set pad [ttk::style lookup EntryFrame -padding] |
| %W configure -padding [expr {$pad eq {} ? 1 : $pad}] |
| } |
| } |
| |
| proc gold_frame {w args} { |
| global use_ttk |
| if {$use_ttk} { |
| eval [linsert $args 0 ttk::frame $w -style Gold.TFrame] |
| } else { |
| eval [linsert $args 0 frame $w -background gold] |
| } |
| } |
| |
| proc tlabel {w args} { |
| global use_ttk |
| if {$use_ttk} { |
| set cmd [list ttk::label $w -style Color.TLabel] |
| foreach {k v} $args { |
| switch -glob -- $k { |
| -activebackground {} |
| default { lappend cmd $k $v } |
| } |
| } |
| eval $cmd |
| } else { |
| eval [linsert $args 0 label $w] |
| } |
| } |
| |
| # The padded label gets used in the about class. |
| proc paddedlabel {w args} { |
| global use_ttk |
| if {$use_ttk} { |
| eval [linsert $args 0 ttk::label $w -style Padded.TLabel] |
| } else { |
| eval [linsert $args 0 label $w \ |
| -padx 5 -pady 5 \ |
| -justify left \ |
| -anchor w \ |
| -borderwidth 1 \ |
| -relief solid] |
| } |
| } |
| |
| # Create a toplevel for use as a dialog. |
| # If available, sets the EWMH dialog hint and if ttk is enabled |
| # place a themed frame over the surface. |
| proc Dialog {w args} { |
| eval [linsert $args 0 toplevel $w -class Dialog] |
| catch {wm attributes $w -type dialog} |
| pave_toplevel $w |
| return $w |
| } |
| |
| # Tk toplevels are not themed - so pave it over with a themed frame to get |
| # the base color correct per theme. |
| proc pave_toplevel {w} { |
| global use_ttk |
| if {$use_ttk && ![winfo exists $w.!paving]} { |
| set paving [ttk::frame $w.!paving] |
| place $paving -x 0 -y 0 -relwidth 1 -relheight 1 |
| lower $paving |
| } |
| } |
| |
| # Create a scrolled listbox with appropriate border for the current theme. |
| # On many themes the border for a scrolled listbox needs to go around the |
| # listbox and the scrollbar. |
| proc slistbox {w args} { |
| global use_ttk NS |
| if {$use_ttk} { |
| set f [ttk::frame $w -style SListbox.TFrame -padding 2] |
| } else { |
| set f [frame $w -relief flat] |
| } |
| if {[catch { |
| if {$use_ttk} { |
| eval [linsert $args 0 listbox $f.list -relief flat \ |
| -highlightthickness 0 -borderwidth 0] |
| } else { |
| eval [linsert $args 0 listbox $f.list] |
| } |
| ${NS}::scrollbar $f.vs -command [list $f.list yview] |
| $f.list configure -yscrollcommand [list $f.vs set] |
| grid $f.list $f.vs -sticky news |
| grid rowconfigure $f 0 -weight 1 |
| grid columnconfigure $f 0 -weight 1 |
| bind $f.list <<ListboxSelect>> \ |
| [list event generate $w <<ListboxSelect>>] |
| interp hide {} $w |
| interp alias {} $w {} $f.list |
| } err]} { |
| destroy $f |
| return -code error $err |
| } |
| return $w |
| } |
| |
| # fetch the background color from a widget. |
| proc get_bg_color {w} { |
| global use_ttk |
| if {$use_ttk} { |
| set bg [ttk::style lookup [winfo class $w] -background] |
| } else { |
| set bg [$w cget -background] |
| } |
| return $bg |
| } |
| |
| # ttk::spinbox didn't get added until 8.6 |
| proc tspinbox {w args} { |
| global use_ttk |
| if {$use_ttk && [llength [info commands ttk::spinbox]] > 0} { |
| eval [linsert $args 0 ttk::spinbox $w] |
| } else { |
| eval [linsert $args 0 spinbox $w] |
| } |
| } |
| |
| # Create a text widget with any theme specific properties. |
| proc ttext {w args} { |
| global use_ttk |
| if {$use_ttk} { |
| switch -- [ttk_get_current_theme] { |
| "vista" - "xpnative" { |
| lappend args -highlightthickness 0 -borderwidth 0 |
| } |
| } |
| } |
| set w [eval [linsert $args 0 text $w]] |
| if {$use_ttk} { |
| if {[winfo class [winfo parent $w]] eq "EntryFrame"} { |
| bind $w <FocusIn> {[winfo parent %W] state focus} |
| bind $w <FocusOut> {[winfo parent %W] state !focus} |
| } |
| } |
| return $w |
| } |
| |
| # themed frame suitable for surrounding a text field. |
| proc textframe {w args} { |
| global use_ttk |
| if {$use_ttk} { |
| if {[catch {ttk::style layout EntryFrame}]} { |
| InitEntryFrame |
| } |
| eval [linsert $args 0 ttk::frame $w -class EntryFrame -style EntryFrame] |
| } else { |
| eval [linsert $args 0 frame $w] |
| } |
| return $w |
| } |
| |
| proc tentry {w args} { |
| global use_ttk |
| if {$use_ttk} { |
| InitTheme |
| ttk::entry $w -style Edged.Entry |
| } else { |
| entry $w |
| } |
| |
| rename $w _$w |
| interp alias {} $w {} tentry_widgetproc $w |
| eval [linsert $args 0 tentry_widgetproc $w configure] |
| return $w |
| } |
| proc tentry_widgetproc {w cmd args} { |
| global use_ttk |
| switch -- $cmd { |
| state { |
| if {$use_ttk} { |
| return [uplevel 1 [list _$w $cmd] $args] |
| } else { |
| if {[lsearch -exact $args pressed] != -1} { |
| _$w configure -background lightpink |
| } else { |
| _$w configure -background lightgreen |
| } |
| } |
| } |
| configure { |
| if {$use_ttk} { |
| if {[set n [lsearch -exact $args -background]] != -1} { |
| set args [lreplace $args $n [incr n]] |
| if {[llength $args] == 0} {return} |
| } |
| } |
| return [uplevel 1 [list _$w $cmd] $args] |
| } |
| default { return [uplevel 1 [list _$w $cmd] $args] } |
| } |
| } |
| |
| # Tk 8.6 provides a standard font selection dialog. This uses the native |
| # dialogs on Windows and MacOSX or a standard Tk dialog on X11. |
| proc tchoosefont {w title familyvar sizevar} { |
| if {[package vsatisfies [package provide Tk] 8.6]} { |
| upvar #0 $familyvar family |
| upvar #0 $sizevar size |
| tk fontchooser configure -parent $w -title $title \ |
| -font [list $family $size] \ |
| -command [list on_choosefont $familyvar $sizevar] |
| tk fontchooser show |
| } else { |
| choose_font::pick $w $title $familyvar $sizevar |
| } |
| } |
| |
| # Called when the Tk 8.6 fontchooser selects a font. |
| proc on_choosefont {familyvar sizevar font} { |
| upvar #0 $familyvar family |
| upvar #0 $sizevar size |
| set font [font actual $font] |
| set family [dict get $font -family] |
| set size [dict get $font -size] |
| } |
| |
| # Local variables: |
| # mode: tcl |
| # indent-tabs-mode: t |
| # tab-width: 4 |
| # End: |
