summaryrefslogtreecommitdiff
path: root/git-gui/lib/themed.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'git-gui/lib/themed.tcl')
-rw-r--r--git-gui/lib/themed.tcl355
1 files changed, 355 insertions, 0 deletions
diff --git a/git-gui/lib/themed.tcl b/git-gui/lib/themed.tcl
new file mode 100644
index 0000000..88b3119
--- /dev/null
+++ b/git-gui/lib/themed.tcl
@@ -0,0 +1,355 @@
+# 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: