1# as_style.tcl --
2#
3#	This file implements package style::as.
4#
5# Copyright (c) 2003 ActiveState Corporation, a division of Sophos
6#
7# Basic use:
8#
9# style::as::init ?which?
10# style::as::reset ?which?
11# style::as::enable ?what ?args??
12#	ie: enable control-mousewheel local|global
13#
14
15package require Tk
16
17namespace eval style::as {
18    variable version 1.4
19    variable highlightbg "#316AC5" ; # SystemHighlight
20    variable highlightfg "white"   ; # SystemHighlightText
21    variable bg          "white"   ; # SystemWindow
22    variable fg          "black"   ; # SystemWindowText
23    if {[string equal $::tcl_platform(platform) "windows"]} {
24	# Use the system colors on Windows, as they can adapt
25	# to the user's personal color scheme
26	set highlightbg "SystemHighlight"
27	set highlightfg "SystemHighlightText"
28	set bg          "SystemWindow"
29	set fg          "SystemWindowText"
30    }
31
32    # This may need to be adjusted for some window managers that are
33    # more aggressive with their own Xdefaults (like KDE and CDE)
34    variable prio "widgetDefault"
35
36    # assume MouseWheel binding is the same across widget classes
37    variable mw
38    set mw(classes) [list Text Listbox Table TreeCtrl]
39    if {![info exists mw(binding)]} {
40	# do this only once, in case of re-source-ing
41	set mw(binding) [bind Text <MouseWheel>]
42	set mw(s-binding) [bind Text <Shift-MouseWheel>]
43	if {[tk windowingsystem] eq "x11"} {
44	    set mw(binding4) [bind Text <4>]
45	    set mw(binding5) [bind Text <5>]
46	}
47    }
48    if {[tk windowingsystem] eq "aqua"} {
49	set mw(ctrl) "Command"
50    } else {
51	set mw(ctrl) "Control"
52    }
53}; # end of namespace style::as
54
55proc style::as::init {args} {
56    package require Tk
57    variable prio
58
59    if {[llength $args]} {
60	set arg [lindex $args 0]
61	set len [string length $arg]
62	if {$len > 2 && [string equal -len $len $arg "-priority"]} {
63	    set prio [lindex $args 1]
64	    set args [lrange $args 2 end]
65	}
66    }
67    if {[llength $args]} {
68	foreach what $args {
69	    style::as::init_$what
70	}
71    } else {
72	foreach cmd [info procs init_*] {
73	    $cmd
74	}
75    }
76
77    if {$::tcl_platform(os) eq "Windows CE"} {
78	# WinCE is for small screens, with 240x320 (QVGA) the most common.
79	# Adapt the defaults to that size.
80	option add *font			{Tahoma 7} $prio
81	option add *Button.borderWidth		1 $prio
82	option add *Entry.borderWidth		1 $prio
83	option add *Listbox.borderWidth		1 $prio
84	option add *Spinbox.borderWidth		1 $prio
85	option add *Text.borderWidth		1 $prio
86	option add *Scrollbar.width		11 $prio
87	option add *padY			0 $prio
88    }
89}
90proc style::as::reset {args} {
91    if {[llength $args]} {
92	foreach what $args {
93	    style::as::reset_$what
94	}
95    } else {
96	foreach cmd [info commands style::as::reset_*] {
97	    $cmd
98	}
99    }
100}
101proc style::as::enable {what args} {
102    variable mw
103    switch -exact $what {
104	mousewheel { init_mousewheel }
105	control-mousewheel {
106	    set type [lindex $args 0]; # should be local or global
107	    bind all <Control-MouseWheel> \
108		[list ::style::as::CtrlMouseWheel %W %X %Y %D $type]
109	    bind all <$mw(ctrl)-plus> \
110		[list ::style::as::CtrlMouseWheel %W %X %Y 120 $type]
111	    bind all <$mw(ctrl)-minus> \
112		[list ::style::as::CtrlMouseWheel %W %X %Y -120 $type]
113	    if {[tk windowingsystem] eq "x11"} {
114		bind all <Control-ButtonPress-4> \
115		    [list ::style::as::CtrlMouseWheel %W %X %Y 120 $type]
116		bind all <Control-ButtonPress-5> \
117		    [list ::style::as::CtrlMouseWheel %W %X %Y -120 $type]
118	    }
119	}
120	default {
121	    return -code error "unknown option \"$what\""
122	}
123    }
124}
125proc style::as::disable {what args} {
126    variable mw
127    switch -exact $what {
128	mousewheel { reset_mousewheel }
129	control-mousewheel {
130	    bind all <Control-MouseWheel> {}
131	    bind all <$mw(ctrl)-plus> {}
132	    bind all <$mw(ctrl)-minus> {}
133	    if {[tk windowingsystem] eq "x11"} {
134		bind all <Control-ButtonPress-4> {}
135		bind all <Control-ButtonPress-5> {}
136	    }
137	}
138	default {
139	    return -code error "unknown option \"$what\""
140	}
141    }
142}
143
144## Fonts
145##
146proc style::as::init_fonts {args} {
147    if {[lsearch -exact [font names] ASfont] == -1} {
148	switch -exact [tk windowingsystem] {
149	    "x11" {
150		set size	-12
151		set family	Helvetica
152		set fsize	-12
153		set ffamily	Courier
154	    }
155	    "win32" {
156		set size	8
157		set family	Tahoma
158		set fsize	9
159		set ffamily	Courier
160	    }
161	    "aqua" - "macintosh" {
162		set size	11
163		set family	"Lucida Grande"
164		set fsize	11
165		set ffamily	Courier
166	    }
167	}
168	font create ASfont      -size $size -family $family
169	font create ASfontBold  -size $size -family $family -weight bold
170	font create ASfontFixed -size $fsize -family $ffamily
171	font create ASfontFixedBold -size $fsize -family $ffamily -weight bold
172	for {set i -2} {$i <= 4} {incr i} {
173	    set isize  [expr {$size + ($i * (($size > 0) ? 1 : -1))}]
174	    set ifsize [expr {$fsize + ($i * (($fsize > 0) ? 1 : -1))}]
175	    font create ASfont$i      -size $isize -family $family
176	    font create ASfontBold$i  -size $isize -family $family -weight bold
177	    font create ASfontFixed$i -size $ifsize -family $ffamily
178	    font create ASfontFixedBold$i \
179		-size $fsize -family $ffamily -weight bold
180	}
181    }
182
183    if {1 || [tk windowingsystem] eq "x11"} {
184	variable prio
185
186	option add *Text.font		ASfontFixed $prio
187	option add *Button.font		ASfont $prio
188	option add *Canvas.font		ASfont $prio
189	option add *Checkbutton.font	ASfont $prio
190	option add *Entry.font		ASfont $prio
191	option add *Label.font		ASfont $prio
192	option add *Labelframe.font	ASfont $prio
193	option add *Listbox.font	ASfont $prio
194	if {[tk windowingsystem] ne "aqua"} {
195	    option add *Menu.font	ASfont $prio
196	}
197	option add *Menubutton.font	ASfont $prio
198	option add *Message.font	ASfont $prio
199	option add *Radiobutton.font	ASfont $prio
200	option add *Spinbox.font	ASfont $prio
201
202	option add *Table.font		ASfont $prio
203	option add *TreeCtrl*font	ASfont $prio
204    }
205}
206
207proc style::as::reset_fonts {args} {
208}
209
210proc style::as::CtrlMouseWheel {W X Y D {what local}} {
211    set w [winfo containing $X $Y]
212    if {[winfo exists $w]} {
213	set top [winfo toplevel $w]
214	while {[catch {$w cget -font} font]
215	       || ![string match "ASfont*" $font]} {
216	    if {$w eq $top} { return }
217	    set w [winfo parent $w]
218	}
219	if {$what eq "local"} {
220	    # get current font size (0 by default) and adjust the current
221	    # widget's font to the next sized preconfigured font
222	    set cnt [regexp -nocase -- {([a-z]+)(\-?\d)?} $font -> name size]
223	    if {$size eq ""} {
224		set size [expr {($D > 0) ? 1 : -1}]
225	    } else {
226		set size [expr {$size + (($D > 0) ? 1 : -1)}]
227	    }
228	    set font $name$size
229	    if {[lsearch -exact [font names] $font] != -1} {
230		catch {$w configure -font $font}
231	    }
232	} else {
233	    # readjust all the font sizes based on the current one
234	    set size [font configure ASfont -size]
235	    # handle negative font sizes (by pixel instead of point)
236	    set neg [expr {($size < 0) ? -1 : 1}]
237	    incr size [expr {$neg * (($D > 0) ? 1 : -1)}]
238	    # but we do have limits on how small/large things can get
239	    if {abs($size) < 6 || abs($size) > 18} { return }
240	    font configure ASfont      -size $size
241	    font configure ASfontBold  -size $size
242	    font configure ASfontFixed -size [expr {$size+(1*$neg)}]
243	    # force reconfigure of this widget with the same font in
244	    # case it doesn't have a WorldChanged function
245	    catch {$w configure -font $font}
246	    if {0} {
247		# we shouldn't need this if the user isn't improperly
248		# switching between global/local ctrl-mswhl modes
249		for {set i -2} {$i <= 4} {incr i} {
250		    font configure ASfont$i      \
251			-size [expr {$size+($i*$neg)}] -family $family
252		    font configure ASfontBold$i  \
253			-size [expr {$size+($i*$neg)}] -family $family \
254			-weight bold
255		    font configure ASfontFixed$i \
256			-size [expr {$size+((1+$i)*$neg)}] -family Courier
257		}
258	    }
259	}
260    }
261}
262
263## Misc
264##
265proc style::as::init_misc {args} {
266    variable prio
267    variable highlightbg
268    variable highlightfg
269    variable bg
270    variable fg
271    option add *ScrolledWindow.ipad		0 $prio
272
273    # Various other common widgets from popular widget sets
274    foreach class {HList Tree Tree.c TixHList TixTree} {
275	option add *$class.borderWidth		1 $prio
276	option add *$class.background		$bg $prio
277	option add *$class.foreground		$fg $prio
278	option add *$class.selectBorderWidth	0 $prio
279	option add *$class.selectForeground	$highlightfg $prio
280	option add *$class.selectBackground	$highlightbg $prio
281    }
282    if {[tk windowingsystem] ne "x11"} {
283	option add *TreeCtrl.useTheme 1
284    }
285}
286
287## Listbox
288##
289proc style::as::init_listbox {args} {
290    variable prio
291    if {[tk windowingsystem] eq "x11"} {
292	variable highlightbg
293	variable highlightfg
294	variable bg
295	variable fg
296	option add *Listbox.background		$bg $prio
297	option add *Listbox.foreground		$fg $prio
298	option add *Listbox.selectBorderWidth	0 $prio
299	option add *Listbox.selectForeground	$highlightfg $prio
300	option add *Listbox.selectBackground	$highlightbg $prio
301    }
302    option add *Listbox.activeStyle		dotbox $prio
303}
304
305## Button
306##
307proc style::as::init_button {args} {
308    variable prio
309    if {[tk windowingsystem] eq "x11"} {
310	option add *Button.padX			1 $prio
311	option add *Button.padY			2 $prio
312    }
313    option add *Button.highlightThickness	1 $prio
314}
315
316## Entry
317##
318proc style::as::init_entry {args} {
319    if {[tk windowingsystem] eq "x11"} {
320	variable prio
321	variable highlightbg
322	variable highlightfg
323	variable bg
324	variable fg
325	option add *Entry.background		$bg $prio
326	option add *Entry.foreground		$fg $prio
327	option add *Entry.selectBorderWidth	0 $prio
328	option add *Entry.selectForeground	$highlightfg $prio
329	option add *Entry.selectBackground	$highlightbg $prio
330    }
331}
332
333## Spinbox
334##
335proc style::as::init_spinbox {args} {
336    if {[tk windowingsystem] eq "x11"} {
337	variable prio
338	variable highlightbg
339	variable highlightfg
340	variable bg
341	variable fg
342	option add *Spinbox.background		$bg $prio
343	option add *Spinbox.foreground		$fg $prio
344	option add *Spinbox.selectBorderWidth	0 $prio
345	option add *Spinbox.selectForeground	$highlightfg $prio
346	option add *Spinbox.selectBackground	$highlightbg $prio
347    }
348}
349
350## Text
351##
352proc style::as::init_text {args} {
353    if {[tk windowingsystem] eq "x11"} {
354	variable prio
355	variable highlightbg
356	variable highlightfg
357	variable bg
358	variable fg
359	option add *Text.background		$bg $prio
360	option add *Text.foreground		$fg $prio
361	option add *Text.selectBorderWidth	0 $prio
362	option add *Text.selectForeground	$highlightfg $prio
363	option add *Text.selectBackground	$highlightbg $prio
364    }
365}
366
367## Menu
368##
369proc style::as::init_menu {args} {
370    if {[tk windowingsystem] eq "x11"} {
371	variable prio
372	variable highlightbg
373	variable highlightfg
374	option add *Menu.activeBackground	$highlightbg $prio
375	option add *Menu.activeForeground	$highlightfg $prio
376	option add *Menu.activeBorderWidth	1 $prio
377	option add *Menu.borderWidth		1 $prio
378    }
379}
380
381## Menubutton
382##
383proc style::as::init_menubutton {args} {
384    variable prio
385    variable highlightbg
386    variable highlightfg
387    option add *Menubutton.activeBackground	$highlightbg $prio
388    option add *Menubutton.activeForeground	$highlightfg $prio
389    option add *Menubutton.activeBorderWidth	1 $prio
390    option add *Menubutton.borderWidth		1 $prio
391    option add *Menubutton.highlightThickness	0 $prio
392    option add *Menubutton*padX			4 $prio
393    option add *Menubutton*padY			3 $prio
394}
395
396## Scrollbar
397##
398proc style::as::init_scrollbar {args} {
399    variable prio
400    if {[tk windowingsystem] eq "x11"} {
401	option add *Scrollbar.width		12 $prio
402	option add *Scrollbar.troughColor	"#bdb6ad" $prio
403    }
404    option add *Scrollbar.borderWidth		1 $prio
405    option add *Scrollbar.highlightThickness	0 $prio
406}
407
408## PanedWindow
409##
410proc style::as::init_panedwindow {args} {
411    variable prio
412    option add *Panedwindow.borderWidth		0 $prio
413    option add *Panedwindow.sashWidth		3 $prio
414    option add *Panedwindow.showHandle		0 $prio
415    option add *Panedwindow.sashPad		0 $prio
416    option add *Panedwindow.sashRelief		flat $prio
417    option add *Panedwindow.relief		flat $prio
418}
419
420## MouseWheel
421##
422proc style::as::MouseWheel {wFired X Y D {shifted 0}} {
423    # Set event to check based on call
424    set evt "<[expr {$shifted?{Shift-}:{}}]MouseWheel>"
425    # do not double-fire in case the class already has a binding
426    if {[bind [winfo class $wFired] $evt] ne ""} { return }
427    # obtain the window the mouse is over
428    set w [winfo containing $X $Y]
429    # if we are outside the app, try and scroll the focus widget
430    if {![winfo exists $w]} { catch {set w [focus]} }
431    if {[winfo exists $w]} {
432	if {[bind $w $evt] ne ""} {
433	    # Awkward ... this widget has a MouseWheel binding, but to
434	    # trigger successfully in it, we must give it focus.
435	    # XXX For now, let's do nothing - maybe check containing != focus?
436	    # Users should restrict MouseWheel bindings to special cases only.
437	    if {0} {
438		catch {focus} old
439		if {$w ne $old} { focus $w }
440		event generate $w $evt -rootx $X -rooty $Y -delta $D
441		if {$w ne $old} { catch {focus $old} }
442	    }
443	    return
444	}
445	# aqua and x11/win32 have different delta handling
446	if {[tk windowingsystem] ne "aqua"} {
447	    set delta [expr {- ($D / 30)}]
448	} else {
449	    set delta [expr {- ($D)}]
450	}
451	# scrollbars have different call conventions
452	if {[string match "*Scrollbar" [winfo class $w]]} {
453	    catch {tk::ScrollByUnits $w \
454		       [string index [$w cget -orient] 0] $delta}
455	} else {
456	    set view [expr {$shifted ? "xview" : "yview"}]
457	    # Walking up to find the proper widget handles cases like
458	    # embedded widgets in a canvas
459	    while {[catch {$w $view scroll $delta units}]
460		   && [winfo toplevel $w] ne $w} {
461		set w [winfo parent $w]
462	    }
463	}
464    }
465}
466proc style::as::init_mousewheel {args} {
467    variable mw
468
469    # Create a catch-all MouseWheel proc & binding and
470    # alter default bindings to allow toplevel binding to control all
471    bind all <MouseWheel> [list ::style::as::MouseWheel %W %X %Y %D 0]
472    bind all <Shift-MouseWheel> [list ::style::as::MouseWheel %W %X %Y %D 1]
473    foreach class $mw(classes) {
474	bind $class <MouseWheel> {}
475	bind $class <Shift-MouseWheel> {}
476    }
477    #if {[bind [winfo toplevel %W] <MouseWheel>] ne ""} { continue }
478    #%W yview scroll [expr {- (%D / 120) * 4}] units
479
480    if {[tk windowingsystem] eq "x11"} {
481	# Support for mousewheels on Linux/Unix commonly comes through
482	# mapping the wheel to the extended buttons.
483	bind all <Button-4> [list ::style::as::MouseWheel %W %X %Y 120]
484	bind all <Button-5> [list ::style::as::MouseWheel %W %X %Y -120]
485	foreach class $mw(classes) {
486	    bind $class <Button-4> {}
487	    bind $class <Button-5> {}
488	}
489    }
490    # Disable this bwidget proc if it exists.  It creates bindings that
491    # are unnecessary and possibly dangerous in combination
492    catch { proc ::BWidget::bindMouseWheel args {} }
493}
494proc style::as::reset_mousewheel {args} {
495    # Remove catch-all MouseWheel binding and restore default bindings
496    variable mw
497
498    bind all <MouseWheel> {}
499    bind all <Shift-MouseWheel> {}
500    foreach class $mw(classes) {
501	bind $class <MouseWheel> $mw(binding)
502	bind $class <Shift-MouseWheel> $mw(s-binding)
503    }
504    if {[tk windowingsystem] eq "x11"} {
505	bind all <Button-4> {}
506	bind all <Button-5> {}
507	foreach class $mw(classes) {
508	    bind $class <Button-4> $mw(binding4)
509	    bind $class <Button-5> $mw(binding5)
510	}
511    }
512}
513
514package provide style::as $style::as::version
515