1# -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*- 2# 3# $Id: Utils.tcl,v 1.4 2004/03/28 02:44:57 hobbs Exp $ 4# 5# Util.tcl -- 6# 7# The Tix utility commands. Some of these commands are 8# replacement of or extensions to the existing TK 9# commands. Occasionaly, you have to use the commands inside 10# this file instead of thestandard TK commands to make your 11# applicatiion work better with Tix. Please read the 12# documentations (programmer's guide, man pages) for information 13# about these utility commands. 14# 15# Copyright (c) 1993-1999 Ioi Kim Lam. 16# Copyright (c) 2000-2001 Tix Project Group. 17# Copyright (c) 2004 ActiveState 18# 19# See the file "license.terms" for information on usage and redistribution 20# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 21# 22 23 24# 25# kludge: should be able to handle all kinds of flags 26# now only handles "-flag value" pairs. 27# 28proc tixHandleArgv {p_argv p_options validFlags} { 29 upvar $p_options opt 30 upvar $p_argv argv 31 32 set old_argv $argv 33 set argv "" 34 35 foreac {flag value} $old_argv { 36 if {[lsearch $validFlags $flag] != -1} { 37 # The caller will handle this option exclusively 38 # It won't be added back to the original arglist 39 # 40 eval $opt($flag,action) $value 41 } else { 42 # The caller does not handle this option 43 # 44 lappend argv $flag 45 lappend argv $value 46 } 47 } 48} 49 50#----------------------------------------------------------------------- 51# tixDisableAll - 52# 53# Disable all members in a sub widget tree 54# 55proc tixDisableAll {w} { 56 foreach x [tixDescendants $w] { 57 catch {$x config -state disabled} 58 } 59} 60 61#---------------------------------------------------------------------- 62# tixEnableAll - 63# 64# enable all members in a sub widget tree 65# 66proc tixEnableAll {w} { 67 foreach x [tixDescendants $w] { 68 catch {$x config -state normal} 69 } 70} 71 72#---------------------------------------------------------------------- 73# tixDescendants - 74# 75# Return a list of all the member of a widget subtree, including 76# the tree's root widget. 77# 78proc tixDescendants {parent} { 79 set des "" 80 lappend des $parent 81 82 foreach w [winfo children $parent] { 83 foreach x [tixDescendants $w] { 84 lappend des $x 85 } 86 } 87 return $des 88} 89 90#---------------------------------------------------------------------- 91# tixTopLevel - 92# 93# Create a toplevel widget and unmap it immediately. This will ensure 94# that this toplevel widgets will not be popped up prematurely when you 95# create Tix widgets inside it. 96# 97# "tixTopLevel" also provide options for you to specify the appearance 98# and behavior of this toplevel. 99# 100# 101# 102proc tixTopLevel {w args} { 103 set opt (-geometry) "" 104 set opt (-minsize) "" 105 set opt (-maxsize) "" 106 set opt (-width) "" 107 set opt (-height) "" 108 109 eval [linsert $args 0 toplevel $w] 110 wm withdraw $w 111} 112 113# This is a big kludge 114# 115# Substitutes all [...] and $.. in the string in $args 116# 117proc tixInt_Expand {args} { 118 return $args 119} 120 121# Print out all the config options of a widget 122# 123proc tixPConfig {w} { 124 puts [join [lsort [$w config]] \n] 125} 126 127proc tixAppendBindTag {w tag} { 128 bindtags $w [concat [bindtags $w] $tag] 129} 130 131proc tixAddBindTag {w tag} { 132 bindtags $w [concat $tag [bindtags $w] ] 133} 134 135proc tixSubwidgetRef {sub} { 136 return $::tixSRef($sub) 137} 138 139proc tixSubwidgetRetCreate {sub ref} { 140 set ::tixSRef($sub) $ref 141} 142 143proc tixSubwidgetRetDelete {sub} { 144 catch {unset ::tixSRef($sub)} 145} 146 147proc tixListboxGetCurrent {listbox} { 148 return [tixEvent flag V] 149} 150 151 152# tixSetMegaWidget -- 153# 154# Associate a subwidget with its mega widget "owner". This is mainly 155# used when we add a new bindtag to a subwidget and we need to find out 156# the name of the mega widget inside the binding. 157# 158proc tixSetMegaWidget {w mega {type any}} { 159 set ::tixMega($type,$w) $mega 160} 161 162proc tixGetMegaWidget {w {type any}} { 163 return $::tixMega($type,$w) 164} 165 166proc tixUnsetMegaWidget {w} { 167 if {[info exists ::tixMega($w)]} { unset ::tixMega($w) } 168} 169 170# tixBusy : display busy cursors on a window 171# 172# 173# Should flush the event queue (but not do any idle tasks) before blocking 174# the target window (I am not sure if it is aready doing so ) 175# 176# ToDo: should take some additional windows to raise 177# 178proc tixBusy {w flag {focuswin ""}} { 179 180 if {[info command tixInputOnly] == ""} { 181 return 182 } 183 184 global tixBusy 185 set toplevel [winfo toplevel $w] 186 187 if {![info exists tixBusy(cursor)]} { 188 set tixBusy(cursor) watch 189# set tixBusy(cursor) "[tix getbitmap hourglass] \ 190# [string range [tix getbitmap hourglass.mask] 1 end]\ 191# black white" 192 } 193 194 if {$toplevel eq "."} { 195 set inputonly0 .__tix__busy0 196 set inputonly1 .__tix__busy1 197 set inputonly2 .__tix__busy2 198 set inputonly3 .__tix__busy3 199 } else { 200 set inputonly0 $toplevel.__tix__busy0 201 set inputonly1 $toplevel.__tix__busy1 202 set inputonly2 $toplevel.__tix__busy2 203 set inputonly3 $toplevel.__tix__busy3 204 } 205 206 if {![winfo exists $inputonly0]} { 207 for {set i 0} {$i < 4} {incr i} { 208 tixInputOnly [set inputonly$i] -cursor $tixBusy(cursor) 209 } 210 } 211 212 if {$flag eq "on"} { 213 if {$focuswin != "" && [winfo id $focuswin] != 0} { 214 if {[info exists tixBusy($focuswin,oldcursor)]} { 215 return 216 } 217 set tixBusy($focuswin,oldcursor) [$focuswin cget -cursor] 218 $focuswin config -cursor $tixBusy(cursor) 219 220 set x1 [expr {[winfo rootx $focuswin]-[winfo rootx $toplevel]}] 221 set y1 [expr {[winfo rooty $focuswin]-[winfo rooty $toplevel]}] 222 223 set W [winfo width $focuswin] 224 set H [winfo height $focuswin] 225 set x2 [expr {$x1 + $W}] 226 set y2 [expr {$y1 + $H}] 227 228 229 if {$y1 > 0} { 230 tixMoveResizeWindow $inputonly0 0 0 10000 $y1 231 } 232 if {$x1 > 0} { 233 tixMoveResizeWindow $inputonly1 0 0 $x1 10000 234 } 235 tixMoveResizeWindow $inputonly2 0 $y2 10000 10000 236 tixMoveResizeWindow $inputonly3 $x2 0 10000 10000 237 238 for {set i 0} {$i < 4} {incr i} { 239 tixMapWindow [set inputonly$i] 240 tixRaiseWindow [set inputonly$i] 241 } 242 tixFlushX $w 243 } else { 244 tixMoveResizeWindow $inputonly0 0 0 10000 10000 245 tixMapWindow $inputonly0 246 tixRaiseWindow $inputonly0 247 } 248 } else { 249 tixUnmapWindow $inputonly0 250 tixUnmapWindow $inputonly1 251 tixUnmapWindow $inputonly2 252 tixUnmapWindow $inputonly3 253 254 if {$focuswin != "" && [winfo id $focuswin] != 0} { 255 if {[info exists tixBusy($focuswin,oldcursor)]} { 256 $focuswin config -cursor $tixBusy($focuswin,oldcursor) 257 if {[info exists tixBusy($focuswin,oldcursor)]} { 258 unset tixBusy($focuswin,oldcursor) 259 } 260 } 261 } 262 } 263} 264 265proc tixOptionName {w} { 266 return [string range $w 1 end] 267} 268 269proc tixSetSilent {chooser value} { 270 $chooser config -disablecallback true 271 $chooser config -value $value 272 $chooser config -disablecallback false 273} 274 275# This command is useful if you want to ingore the arguments 276# passed by the -command or -browsecmd options of the Tix widgets. E.g 277# 278# tixFileSelectDialog .c -command "puts foo; tixBreak" 279# 280# 281proc tixBreak {args} {} 282 283#---------------------------------------------------------------------- 284# tixDestroy -- deletes a Tix class object (not widget classes) 285#---------------------------------------------------------------------- 286proc tixDestroy {w} { 287 upvar #0 $w data 288 289 set destructor "" 290 if {[info exists data(className)]} { 291 catch { 292 set destructor [tixGetMethod $w $data(className) Destructor] 293 } 294 } 295 if {$destructor != ""} { 296 $destructor $w 297 } 298 catch {rename $w ""} 299 catch {unset data} 300 return "" 301} 302 303proc tixPushGrab {args} { 304 global tix_priv 305 306 if {![info exists tix_priv(grab-list)]} { 307 set tix_priv(grab-list) "" 308 set tix_priv(grab-mode) "" 309 set tix_priv(grab-nopush) "" 310 } 311 312 set len [llength $args] 313 if {$len == 1} { 314 set opt "" 315 set w [lindex $args 0] 316 } elseif {$len == 2} { 317 set opt [lindex $args 0] 318 set w [lindex $args 1] 319 } else { 320 error "wrong # of arguments: tixPushGrab ?-global? window" 321 } 322 323 # Not everyone will call tixPushGrab. If someone else has a grab already 324 # save that one as well, so that we can restore that later 325 # 326 set last [lindex $tix_priv(grab-list) end] 327 set current [grab current $w] 328 329 if {$current ne "" && $current ne $last} { 330 # Someone called "grab" directly 331 # 332 lappend tix_priv(grab-list) $current 333 lappend tix_priv(grab-mode) [grab status $current] 334 lappend tix_priv(grab-nopush) 1 335 } 336 337 # Now push myself into the stack 338 # 339 lappend tix_priv(grab-list) $w 340 lappend tix_priv(grab-mode) $opt 341 lappend tix_priv(grab-nopush) 0 342 343 if {$opt eq "-global"} { 344 grab -global $w 345 } else { 346 grab $w 347 } 348} 349 350proc tixPopGrab {} { 351 global tix_priv 352 353 if {![info exists tix_priv(grab-list)]} { 354 set tix_priv(grab-list) "" 355 set tix_priv(grab-mode) "" 356 set tix_priv(grab-nopush) "" 357 } 358 359 set len [llength $tix_priv(grab-list)] 360 if {$len <= 0} { 361 error "no window is grabbed by tixGrab" 362 } 363 364 set w [lindex $tix_priv(grab-list) end] 365 grab release $w 366 367 if {$len > 1} { 368 set tix_priv(grab-list) [lrange $tix_priv(grab-list) 0 end-1] 369 set tix_priv(grab-mode) [lrange $tix_priv(grab-mode) 0 end-1] 370 set tix_priv(grab-nopush) [lrange $tix_priv(grab-nopush) 0 end-1] 371 372 set w [lindex $tix_priv(grab-list) end] 373 set m [lindex $tix_priv(grab-list) end] 374 set np [lindex $tix_priv(grab-nopush) end] 375 376 if {$np == 1} { 377 # We have a grab set by "grab" 378 # 379 set len [llength $tix_priv(grab-list)] 380 381 if {$len > 1} { 382 set tix_priv(grab-list) [lrange $tix_priv(grab-list) 0 end-1] 383 set tix_priv(grab-mode) [lrange $tix_priv(grab-mode) 0 end-1] 384 set tix_priv(grab-nopush) \ 385 [lrange $tix_priv(grab-nopush) 0 end-1] 386 } else { 387 set tix_priv(grab-list) "" 388 set tix_priv(grab-mode) "" 389 set tix_priv(grab-nopush) "" 390 } 391 } 392 393 if {$m == "-global"} { 394 grab -global $w 395 } else { 396 grab $w 397 } 398 } else { 399 set tix_priv(grab-list) "" 400 set tix_priv(grab-mode) "" 401 set tix_priv(grab-nopush) "" 402 } 403} 404 405proc tixWithinWindow {wid rootX rootY} { 406 set wc [winfo containing $rootX $rootY] 407 if {$wid eq $wc} { return 1 } 408 409 # no see if it is an enclosing parent 410 set rx1 [winfo rootx $wid] 411 set ry1 [winfo rooty $wid] 412 set rw [winfo width $wid] 413 set rh [winfo height $wid] 414 set rx2 [expr {$rx1+$rw}] 415 set ry2 [expr {$ry1+$rh}] 416 417 if {$rootX >= $rx1 && $rootX < $rx2 && $rootY >= $ry1 && $rootY < $ry2} { 418 return 1 419 } else { 420 return 0 421 } 422} 423 424proc tixWinWidth {w} { 425 set W [winfo width $w] 426 set bd [expr {[$w cget -bd] + [$w cget -highlightthickness]}] 427 428 return [expr {$W - 2*$bd}] 429} 430 431proc tixWinHeight {w} { 432 set H [winfo height $w] 433 set bd [expr {[$w cget -bd] + [$w cget -highlightthickness]}] 434 435 return [expr {$H - 2*$bd}] 436} 437 438# junk? 439# 440proc tixWinCmd {w} { 441 return [winfo command $w] 442} 443