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