summaryrefslogtreecommitdiff
path: root/lib/themed.tcl
blob: 8b88d3678b7ddd802260f47bcfeff8a895d93f3f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
# Functions for supporting the use of themed Tk widgets in git-gui.
# Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>

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
		}
	}

	# Handle either current Tk or older versions of 8.5
	if {[catch {set theme [ttk::style theme use]}]} {
		set theme  $::ttk::currentTheme
	}

	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]]
	}
}

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]
	}
}

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: