1# ---------------------------------------------------------------------------- 2# utils.tcl 3# This file is part of Unifix BWidget Toolkit 4# $Id: utils.tcl,v 1.18 2009/10/25 20:55:36 oberdorfer Exp $ 5# ---------------------------------------------------------------------------- 6# Index of commands: 7# - GlobalVar::exists 8# - GlobalVar::setvarvar 9# - GlobalVar::getvarvar 10# - BWidget::assert 11# - BWidget::clonename 12# - BWidget::get3dcolor 13# - BWidget::XLFDfont 14# - BWidget::place 15# - BWidget::grab 16# - BWidget::focus 17# - BWidget::bindMiddleMouseMovement 18# - BWidget::getSystemFontProperties 19# - BWidget::createSystemFonts 20# ---------------------------------------------------------------------------- 21 22namespace eval GlobalVar { 23 proc use {} {} 24} 25 26 27namespace eval BWidget { 28 variable _top 29 variable _gstack {} 30 variable _fstack {} 31 proc use {} {} 32} 33 34 35# ---------------------------------------------------------------------------- 36# Command GlobalVar::exists 37# ---------------------------------------------------------------------------- 38proc GlobalVar::exists { varName } { 39 return [uplevel \#0 [list info exists $varName]] 40} 41 42 43# ---------------------------------------------------------------------------- 44# Command GlobalVar::setvar 45# ---------------------------------------------------------------------------- 46proc GlobalVar::setvar { varName value } { 47 return [uplevel \#0 [list set $varName $value]] 48} 49 50 51# ---------------------------------------------------------------------------- 52# Command GlobalVar::getvar 53# ---------------------------------------------------------------------------- 54proc GlobalVar::getvar { varName } { 55 return [uplevel \#0 [list set $varName]] 56} 57 58 59# ---------------------------------------------------------------------------- 60# Command GlobalVar::tracevar 61# ---------------------------------------------------------------------------- 62proc GlobalVar::tracevar { cmd varName args } { 63 return [uplevel \#0 [list trace $cmd $varName] $args] 64} 65 66 67 68# ---------------------------------------------------------------------------- 69# Command BWidget::lreorder 70# ---------------------------------------------------------------------------- 71proc BWidget::lreorder { list neworder } { 72 set pos 0 73 set newlist {} 74 foreach e $neworder { 75 if { [lsearch -exact $list $e] != -1 } { 76 lappend newlist $e 77 set tabelt($e) 1 78 } 79 } 80 set len [llength $newlist] 81 if { !$len } { 82 return $list 83 } 84 if { $len == [llength $list] } { 85 return $newlist 86 } 87 set pos 0 88 foreach e $list { 89 if { ![info exists tabelt($e)] } { 90 set newlist [linsert $newlist $pos $e] 91 } 92 incr pos 93 } 94 return $newlist 95} 96 97 98# ---------------------------------------------------------------------------- 99# Command BWidget::assert 100# ---------------------------------------------------------------------------- 101proc BWidget::assert { exp {msg ""}} { 102 set res [uplevel 1 expr $exp] 103 if { !$res} { 104 if { $msg == "" } { 105 return -code error "Assertion failed: {$exp}" 106 } else { 107 return -code error $msg 108 } 109 } 110} 111 112 113# ---------------------------------------------------------------------------- 114# Command BWidget::clonename 115# ---------------------------------------------------------------------------- 116proc BWidget::clonename { menu } { 117 set path "" 118 set menupath "" 119 set found 0 120 foreach widget [lrange [split $menu "."] 1 end] { 121 if { $found || [winfo class "$path.$widget"] == "Menu" } { 122 set found 1 123 append menupath "#" $widget 124 append path "." $menupath 125 } else { 126 append menupath "#" $widget 127 append path "." $widget 128 } 129 } 130 return $path 131} 132 133 134# ---------------------------------------------------------------------------- 135# Command BWidget::getname 136# ---------------------------------------------------------------------------- 137proc BWidget::getname { name } { 138 if { [string length $name] } { 139 set text [option get . "${name}Name" ""] 140 if { [string length $text] } { 141 return [parsetext $text] 142 } 143 } 144 return {} 145 } 146 147 148# ---------------------------------------------------------------------------- 149# Command BWidget::parsetext 150# ---------------------------------------------------------------------------- 151proc BWidget::parsetext { text } { 152 set result "" 153 set index -1 154 set start 0 155 while { [string length $text] } { 156 set idx [string first "&" $text] 157 if { $idx == -1 } { 158 append result $text 159 set text "" 160 } else { 161 set char [string index $text [expr {$idx+1}]] 162 if { $char == "&" } { 163 append result [string range $text 0 $idx] 164 set text [string range $text [expr {$idx+2}] end] 165 set start [expr {$start+$idx+1}] 166 } else { 167 append result [string range $text 0 [expr {$idx-1}]] 168 set text [string range $text [expr {$idx+1}] end] 169 incr start $idx 170 set index $start 171 } 172 } 173 } 174 return [list $result $index] 175} 176 177 178# ---------------------------------------------------------------------------- 179# Command BWidget::get3dcolor 180# ---------------------------------------------------------------------------- 181proc BWidget::get3dcolor { path bgcolor } { 182 set fmt "#%04x%04x%04x" 183 184 foreach val [winfo rgb $path $bgcolor] { 185 lappend dark [expr {60*$val/100}] 186 set tmp1 [expr {14*$val/10}] 187 if { $tmp1 > 65535 } { 188 set tmp1 65535 189 } 190 set tmp2 [expr {(65535+$val)/2}] 191 lappend light [expr {($tmp1 > $tmp2) ? $tmp1:$tmp2}] 192 } 193 return [list [eval format $fmt $dark] [eval format $fmt $light]] 194} 195 196 197# ---------------------------------------------------------------------------- 198# Command BWidget::XLFDfont 199# ---------------------------------------------------------------------------- 200proc BWidget::XLFDfont { cmd args } { 201 switch -- $cmd { 202 create { 203 set font "-*-*-*-*-*-*-*-*-*-*-*-*-*-*" 204 } 205 configure { 206 set font [lindex $args 0] 207 set args [lrange $args 1 end] 208 } 209 default { 210 return -code error "XLFDfont: commande incorrect: $cmd" 211 } 212 } 213 set lfont [split $font "-"] 214 if { [llength $lfont] != 15 } { 215 return -code error "XLFDfont: description XLFD incorrect: $font" 216 } 217 218 foreach {option value} $args { 219 switch -- $option { 220 -foundry { set index 1 } 221 -family { set index 2 } 222 -weight { set index 3 } 223 -slant { set index 4 } 224 -size { set index 7 } 225 default { return -code error "XLFDfont: option incorrecte: $option" } 226 } 227 set lfont [lreplace $lfont $index $index $value] 228 } 229 return [join $lfont "-"] 230} 231 232 233# ---------------------------------------------------------------------------- 234# Command BWidget::place 235# ---------------------------------------------------------------------------- 236# 237# Notes: 238# For Windows systems with more than one monitor the available screen area may 239# have negative positions. Geometry settings with negative numbers are used 240# under X to place wrt the right or bottom of the screen. On windows, Tk 241# continues to do this. However, a geometry such as 100x100+-200-100 can be 242# used to place a window onto a secondary monitor. Passing the + gets Tk 243# to pass the remainder unchanged so the Windows manager then handles -200 244# which is a position on the left hand monitor. 245# I've tested this for left, right, above and below the primary monitor. 246# Currently there is no way to ask Tk the extent of the Windows desktop in 247# a multi monitor system. Nor what the legal co-ordinate range might be. 248# 249proc BWidget::place { path w h args } { 250 variable _top 251 252 update idletasks 253 254 # If the window is not mapped, it may have any current size. 255 # Then use required size, but bound it to the screen width. 256 # This is mostly inexact, because any toolbars will still be removed 257 # which may reduce size. 258 if { $w == 0 && [winfo ismapped $path] } { 259 set w [winfo width $path] 260 } else { 261 if { $w == 0 } { 262 set w [winfo reqwidth $path] 263 } 264 set vsw [winfo vrootwidth $path] 265 if { $w > $vsw } { set w $vsw } 266 } 267 268 if { $h == 0 && [winfo ismapped $path] } { 269 set h [winfo height $path] 270 } else { 271 if { $h == 0 } { 272 set h [winfo reqheight $path] 273 } 274 set vsh [winfo vrootheight $path] 275 if { $h > $vsh } { set h $vsh } 276 } 277 278 set arglen [llength $args] 279 if { $arglen > 3 } { 280 return -code error "BWidget::place: bad number of argument" 281 } 282 283 if { $arglen > 0 } { 284 set where [lindex $args 0] 285 set list [list "at" "center" "left" "right" "above" "below"] 286 set idx [lsearch $list $where] 287 if { $idx == -1 } { 288 return -code error [BWidget::badOptionString position $where $list] 289 } 290 if { $idx == 0 } { 291 set err [catch { 292 # purposely removed the {} around these expressions - [PT] 293 set x [expr int([lindex $args 1])] 294 set y [expr int([lindex $args 2])] 295 }] 296 if { $err } { 297 return -code error "BWidget::place: incorrect position" 298 } 299 if {$::tcl_platform(platform) == "windows"} { 300 # handle windows multi-screen. -100 != +-100 301 if {[string index [lindex $args 1] 0] != "-"} { 302 set x "+$x" 303 } 304 if {[string index [lindex $args 2] 0] != "-"} { 305 set y "+$y" 306 } 307 } else { 308 if { $x >= 0 } { 309 set x "+$x" 310 } 311 if { $y >= 0 } { 312 set y "+$y" 313 } 314 } 315 } else { 316 if { $arglen == 2 } { 317 set widget [lindex $args 1] 318 if { ![winfo exists $widget] } { 319 return -code error "BWidget::place: \"$widget\" does not exist" 320 } 321 } else { 322 set widget . 323 } 324 set sw [winfo screenwidth $path] 325 set sh [winfo screenheight $path] 326 if { $idx == 1 } { 327 if { $arglen == 2 } { 328 # center to widget 329 set x0 [expr {[winfo rootx $widget] + ([winfo width $widget] - $w)/2}] 330 set y0 [expr {[winfo rooty $widget] + ([winfo height $widget] - $h)/2}] 331 } else { 332 # center to screen 333 set x0 [expr {($sw - $w)/2 - [winfo vrootx $path]}] 334 set y0 [expr {($sh - $h)/2 - [winfo vrooty $path]}] 335 } 336 set x "+$x0" 337 set y "+$y0" 338 if {$::tcl_platform(platform) != "windows"} { 339 if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]} 340 if { $x0 < 0 } {set x "+0"} 341 if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]} 342 if { $y0 < 0 } {set y "+0"} 343 } 344 } else { 345 set x0 [winfo rootx $widget] 346 set y0 [winfo rooty $widget] 347 set x1 [expr {$x0 + [winfo width $widget]}] 348 set y1 [expr {$y0 + [winfo height $widget]}] 349 if { $idx == 2 || $idx == 3 } { 350 set y "+$y0" 351 if {$::tcl_platform(platform) != "windows"} { 352 if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]} 353 if { $y0 < 0 } {set y "+0"} 354 } 355 if { $idx == 2 } { 356 # try left, then right if out, then 0 if out 357 if { $x0 >= $w } { 358 set x [expr {$x0-$w}] 359 } elseif { $x1+$w <= $sw } { 360 set x "+$x1" 361 } else { 362 set x "+0" 363 } 364 } else { 365 # try right, then left if out, then 0 if out 366 if { $x1+$w <= $sw } { 367 set x "+$x1" 368 } elseif { $x0 >= $w } { 369 set x [expr {$x0-$w}] 370 } else { 371 set x "-0" 372 } 373 } 374 } else { 375 set x "+$x0" 376 if {$::tcl_platform(platform) != "windows"} { 377 if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]} 378 if { $x0 < 0 } {set x "+0"} 379 } 380 if { $idx == 4 } { 381 # try top, then bottom, then 0 382 if { $h <= $y0 } { 383 set y [expr {$y0-$h}] 384 } elseif { $y1+$h <= $sh } { 385 set y "+$y1" 386 } else { 387 set y "+0" 388 } 389 } else { 390 # try bottom, then top, then 0 391 if { $y1+$h <= $sh } { 392 set y "+$y1" 393 } elseif { $h <= $y0 } { 394 set y [expr {$y0-$h}] 395 } else { 396 set y "-0" 397 } 398 } 399 } 400 } 401 } 402 403 ## If there's not a + or - in front of the number, we need to add one. 404 if {[string is integer [string index $x 0]]} { set x +$x } 405 if {[string is integer [string index $y 0]]} { set y +$y } 406 407 wm geometry $path "${w}x${h}${x}${y}" 408 } else { 409 wm geometry $path "${w}x${h}" 410 } 411 update idletasks 412} 413 414 415# ---------------------------------------------------------------------------- 416# Command BWidget::grab 417# ---------------------------------------------------------------------------- 418proc BWidget::grab { option path } { 419 variable _gstack 420 421 if { $option == "release" } { 422 catch {::grab release $path} 423 while { [llength $_gstack] } { 424 set grinfo [lindex $_gstack end] 425 set _gstack [lreplace $_gstack end end] 426 foreach {oldg mode} $grinfo { 427 if { ![string equal $oldg $path] && [winfo exists $oldg] } { 428 if { $mode == "global" } { 429 catch {::grab -global $oldg} 430 } else { 431 catch {::grab $oldg} 432 } 433 return 434 } 435 } 436 } 437 } else { 438 set oldg [::grab current] 439 if { $oldg != "" } { 440 lappend _gstack [list $oldg [::grab status $oldg]] 441 } 442 if { $option == "global" } { 443 ::grab -global $path 444 } else { 445 ::grab $path 446 } 447 } 448} 449 450 451# ---------------------------------------------------------------------------- 452# Command BWidget::focus 453# ---------------------------------------------------------------------------- 454proc BWidget::focus { option path {refocus 1} } { 455 variable _fstack 456 457 if { $option == "release" } { 458 while { [llength $_fstack] } { 459 set oldf [lindex $_fstack end] 460 set _fstack [lreplace $_fstack end end] 461 if { ![string equal $oldf $path] && [winfo exists $oldf] } { 462 if {$refocus} {catch {::focus -force $oldf}} 463 return 464 } 465 } 466 } elseif { $option == "set" } { 467 lappend _fstack [::focus] 468 ::focus -force $path 469 } 470} 471 472# BWidget::refocus -- 473# 474# Helper function used to redirect focus from a container frame in 475# a megawidget to a component widget. Only redirects focus if 476# focus is already on the container. 477# 478# Arguments: 479# container container widget to redirect from. 480# component component widget to redirect to. 481# 482# Results: 483# None. 484 485proc BWidget::refocus {container component} { 486 if { [string equal $container [::focus]] } { 487 ::focus $component 488 } 489 return 490} 491 492## These mirror tk::(Set|Restore)FocusGrab 493 494# BWidget::SetFocusGrab -- 495# swap out current focus and grab temporarily (for dialogs) 496# Arguments: 497# grab new window to grab 498# focus window to give focus to 499# Results: 500# Returns nothing 501# 502proc BWidget::SetFocusGrab {grab {focus {}}} { 503 variable _focusGrab 504 set index "$grab,$focus" 505 506 lappend _focusGrab($index) [::focus] 507 set oldGrab [::grab current $grab] 508 lappend _focusGrab($index) $oldGrab 509 if {[winfo exists $oldGrab]} { 510 lappend _focusGrab($index) [::grab status $oldGrab] 511 } 512 # The "grab" command will fail if another application 513 # already holds the grab. So catch it. 514 catch {::grab $grab} 515 if {[winfo exists $focus]} { 516 ::focus $focus 517 } 518} 519 520# BWidget::RestoreFocusGrab -- 521# restore old focus and grab (for dialogs) 522# Arguments: 523# grab window that had taken grab 524# focus window that had taken focus 525# destroy destroy|withdraw - how to handle the old grabbed window 526# Results: 527# Returns nothing 528# 529proc BWidget::RestoreFocusGrab {grab focus {destroy destroy}} { 530 variable _focusGrab 531 set index "$grab,$focus" 532 if {[info exists _focusGrab($index)]} { 533 foreach {oldFocus oldGrab oldStatus} $_focusGrab($index) break 534 unset _focusGrab($index) 535 } else { 536 set oldGrab "" 537 } 538 539 catch {::focus $oldFocus} 540 ::grab release $grab 541 if {[string equal $destroy "withdraw"]} { 542 wm withdraw $grab 543 } else { 544 ::destroy $grab 545 } 546 if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} { 547 if {[string equal $oldStatus "global"]} { 548 ::grab -global $oldGrab 549 } else { 550 ::grab $oldGrab 551 } 552 } 553} 554 555# BWidget::badOptionString -- 556# 557# Helper function to return a proper error string when an option 558# doesn't match a list of given options. 559# 560# Arguments: 561# type A string that represents the type of option. 562# value The value that is in-valid. 563# list A list of valid options. 564# 565# Results: 566# None. 567proc BWidget::badOptionString {type value list} { 568 set last [lindex $list end] 569 set list [lreplace $list end end] 570 return "bad $type \"$value\": must be [join $list ", "], or $last" 571} 572 573 574proc BWidget::wrongNumArgsString { string } { 575 return "wrong # args: should be \"$string\"" 576} 577 578 579proc BWidget::read_file { file } { 580 set fp [open $file] 581 set x [read $fp [file size $file]] 582 close $fp 583 return $x 584} 585 586 587proc BWidget::classes { class } { 588 variable use 589 590 ${class}::use 591 set classes [list $class] 592 if {![info exists use($class)]} { return } 593 foreach class $use($class) { 594 if {![string equal $class "-classonly"]} { 595 eval lappend classes [classes $class] 596 } 597 } 598 return [lsort -unique $classes] 599} 600 601 602proc BWidget::library { args } { 603 variable use 604 605 set libs [list widget init utils] 606 set classes [list] 607 foreach class $args { 608 ${class}::use 609 eval lappend classes [classes $class] 610 } 611 612 eval lappend libs [lsort -unique $classes] 613 614 set library "" 615 foreach lib $libs { 616 if {![info exists use($lib,file)]} { 617 set file [file join $::BWIDGET::LIBRARY $lib.tcl] 618 } else { 619 set file [file join $::BWIDGET::LIBRARY $use($lib,file).tcl] 620 } 621 append library [read_file $file] 622 } 623 624 return $library 625} 626 627 628proc BWidget::inuse { class } { 629 variable ::Widget::_inuse 630 631 if {![info exists _inuse($class)]} { return 0 } 632 return [expr $_inuse($class) > 0] 633} 634 635 636proc BWidget::write { filename {mode w} } { 637 variable use 638 639 if {![info exists use(classes)]} { return } 640 641 set classes [list] 642 foreach class $use(classes) { 643 if {![inuse $class]} { continue } 644 lappend classes $class 645 } 646 647 set fp [open $filename $mode] 648 puts $fp [eval library $classes] 649 close $fp 650 651 return 652} 653 654 655# BWidget::bindMouseWheel -- 656# 657# Bind mouse wheel actions to a given widget. 658# 659# Arguments: 660# widget - The widget to bind. 661# 662# Results: 663# None. 664proc BWidget::bindMouseWheel { widget } { 665 if {[bind all <MouseWheel>] eq ""} { 666 # style::as and Tk 8.5 have global bindings 667 # Only enable these if no global binding for MouseWheel exists 668 bind $widget <MouseWheel> \ 669 {%W yview scroll [expr {-%D/24}] units} 670 bind $widget <Shift-MouseWheel> \ 671 {%W yview scroll [expr {-%D/120}] pages} 672 bind $widget <Control-MouseWheel> \ 673 {%W yview scroll [expr {-%D/120}] units} 674 } 675 676 if {[bind all <Button-4>] eq ""} { 677 # style::as and Tk 8.5 have global bindings 678 # Only enable these if no global binding for them exists 679 bind $widget <Button-4> {event generate %W <MouseWheel> -delta 120} 680 bind $widget <Button-5> {event generate %W <MouseWheel> -delta -120} 681 } 682} 683 684 685# ---------------------------------------------------------------------------- 686# support for middle mouse button movement 687# ---------------------------------------------------------------------------- 688 689proc BWidget::bindMiddleMouseMovement { widget } { 690 variable __private 691 692 bind $widget <2> { 693 set BWidget::__private(x) %x 694 set BWidget::__private(y) %y 695 %W configure -cursor fleur 696 } 697 bind $widget <B2-ButtonRelease> { 698 %W configure -cursor "" 699 } 700 701 bind $widget <B2-Motion> { 702 set scrollspeed 2 703 set xdir 1 704 set ydir 1 705 if { %x > $BWidget::__private(x) } {set xdir -1} 706 if { %y > $BWidget::__private(y) } {set ydir -1} 707 catch {%W xview scroll [expr $xdir * $scrollspeed] units} 708 catch {%W yview scroll [expr $ydir * $scrollspeed] units} 709 } 710} 711 712 713# ---------------------------------------------------------------------------- 714# utility function for font support 715# ---------------------------------------------------------------------------- 716 717proc ::BWidget::getSystemFontProperties {} { 718 719 array set fp { 720 family "Courier New" 721 stdsize 12 722 headingsize 10 723 captionsize 12 724 tooltipsize 10 725 wheading normal 726 wcaption normal 727 } 728 729 if {$::tcl_version >= 8.4} { 730 set plat [tk windowingsystem] 731 } else { set plat $::tcl_platform(platform) } 732 733 734 switch -exact -- [string tolower $plat] { 735 "win32" - "windows" { 736 if {$::tcl_platform(osVersion) >= 5.0} { 737 set fp(family) "Tahoma" 738 } else { set fp(family) "MS Sans Serif" } 739 set fp(stdsize) 8 740 set fp(headingsize) 8 741 set fp(captionsize) 8 742 set fp(tooltipsize) 8 743 set fp(wcaption) bold 744 } 745 "classic" - "aqua" { 746 set fp(family) "Lucida Grande" 747 set fp(stdsize) 13 748 set fp(headingsize) 11 749 set fp(captionsize) 13 750 set fp(tooltipsize) 12 751 set fp(wcaption) bold 752 } 753 "x11" { 754 if { ![catch {tk::pkgconfig get fontsystem} fs] && 755 [string equal $fs "xft"] } { 756 set fp(family) "sans-serif" 757 } else { set fp(family) "Helvetica" } 758 set fp(stdsize) -12 759 set fp(headingsize) -12 760 set fp(captionsize) -14 761 set fp(tooltipsize) -10 762 set fp(wheading) bold 763 set fp(wcaption) bold 764 } 765 } 766 return [array get fp] 767} 768 769 770# under tk >= 8.5 / tile 0.8, 771# the following predefined fonts are available: 772# TkCaptionFont TkDefaultFont TkFixedFont TkHeadingFont 773# TkIconFont TkMenuFont TkSmallCaptionFont TkTextFont TkTooltipFont 774# to be compatible with older versions and to make sure, 775# those fonts are available at runtime, we need to ensure that they exist: 776 777proc ::BWidget::createSystemFonts {} { 778 variable vars 779 780 array set fp [getSystemFontProperties] 781 set fnames [font names] 782 783 foreach fname { TkCaptionFont TkDefaultFont TkFixedFont TkHeadingFont 784 TkIconFont TkMenuFont TkSmallCaptionFont TkTextFont 785 TkTooltipFont } { 786 787 if {[lsearch $fnames $fname] == -1} { 788 font create $fname -family $fp(family) -size $fp(stdsize) 789 790 switch -- $fname { 791 TkCaptionFont { 792 font configure $fname \ 793 -size $fp(captionsize) -weight $fp(wcaption) 794 } 795 TkHeadingFont { 796 font configure $fname \ 797 -size $fp(headingsize) -weight $fp(wheading) 798 } 799 TkTooltipFont { 800 font configure $fname -size $fp(tooltipsize) 801 } 802 } 803 } 804 } 805} 806 807