调整目录结构
This commit is contained in:
442
Needed/mini-python/tcl/tix8.4.3/Utils.tcl
Normal file
442
Needed/mini-python/tcl/tix8.4.3/Utils.tcl
Normal file
@@ -0,0 +1,442 @@
|
||||
# -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
|
||||
#
|
||||
# $Id: Utils.tcl,v 1.4 2004/03/28 02:44:57 hobbs Exp $
|
||||
#
|
||||
# Util.tcl --
|
||||
#
|
||||
# The Tix utility commands. Some of these commands are
|
||||
# replacement of or extensions to the existing TK
|
||||
# commands. Occasionaly, you have to use the commands inside
|
||||
# this file instead of thestandard TK commands to make your
|
||||
# applicatiion work better with Tix. Please read the
|
||||
# documentations (programmer's guide, man pages) for information
|
||||
# about these utility commands.
|
||||
#
|
||||
# Copyright (c) 1993-1999 Ioi Kim Lam.
|
||||
# Copyright (c) 2000-2001 Tix Project Group.
|
||||
# Copyright (c) 2004 ActiveState
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
|
||||
#
|
||||
# kludge: should be able to handle all kinds of flags
|
||||
# now only handles "-flag value" pairs.
|
||||
#
|
||||
proc tixHandleArgv {p_argv p_options validFlags} {
|
||||
upvar $p_options opt
|
||||
upvar $p_argv argv
|
||||
|
||||
set old_argv $argv
|
||||
set argv ""
|
||||
|
||||
foreac {flag value} $old_argv {
|
||||
if {[lsearch $validFlags $flag] != -1} {
|
||||
# The caller will handle this option exclusively
|
||||
# It won't be added back to the original arglist
|
||||
#
|
||||
eval $opt($flag,action) $value
|
||||
} else {
|
||||
# The caller does not handle this option
|
||||
#
|
||||
lappend argv $flag
|
||||
lappend argv $value
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
#-----------------------------------------------------------------------
|
||||
# tixDisableAll -
|
||||
#
|
||||
# Disable all members in a sub widget tree
|
||||
#
|
||||
proc tixDisableAll {w} {
|
||||
foreach x [tixDescendants $w] {
|
||||
catch {$x config -state disabled}
|
||||
}
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# tixEnableAll -
|
||||
#
|
||||
# enable all members in a sub widget tree
|
||||
#
|
||||
proc tixEnableAll {w} {
|
||||
foreach x [tixDescendants $w] {
|
||||
catch {$x config -state normal}
|
||||
}
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# tixDescendants -
|
||||
#
|
||||
# Return a list of all the member of a widget subtree, including
|
||||
# the tree's root widget.
|
||||
#
|
||||
proc tixDescendants {parent} {
|
||||
set des ""
|
||||
lappend des $parent
|
||||
|
||||
foreach w [winfo children $parent] {
|
||||
foreach x [tixDescendants $w] {
|
||||
lappend des $x
|
||||
}
|
||||
}
|
||||
return $des
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# tixTopLevel -
|
||||
#
|
||||
# Create a toplevel widget and unmap it immediately. This will ensure
|
||||
# that this toplevel widgets will not be popped up prematurely when you
|
||||
# create Tix widgets inside it.
|
||||
#
|
||||
# "tixTopLevel" also provide options for you to specify the appearance
|
||||
# and behavior of this toplevel.
|
||||
#
|
||||
#
|
||||
#
|
||||
proc tixTopLevel {w args} {
|
||||
set opt (-geometry) ""
|
||||
set opt (-minsize) ""
|
||||
set opt (-maxsize) ""
|
||||
set opt (-width) ""
|
||||
set opt (-height) ""
|
||||
|
||||
eval [linsert $args 0 toplevel $w]
|
||||
wm withdraw $w
|
||||
}
|
||||
|
||||
# This is a big kludge
|
||||
#
|
||||
# Substitutes all [...] and $.. in the string in $args
|
||||
#
|
||||
proc tixInt_Expand {args} {
|
||||
return $args
|
||||
}
|
||||
|
||||
# Print out all the config options of a widget
|
||||
#
|
||||
proc tixPConfig {w} {
|
||||
puts [join [lsort [$w config]] \n]
|
||||
}
|
||||
|
||||
proc tixAppendBindTag {w tag} {
|
||||
bindtags $w [concat [bindtags $w] $tag]
|
||||
}
|
||||
|
||||
proc tixAddBindTag {w tag} {
|
||||
bindtags $w [concat $tag [bindtags $w] ]
|
||||
}
|
||||
|
||||
proc tixSubwidgetRef {sub} {
|
||||
return $::tixSRef($sub)
|
||||
}
|
||||
|
||||
proc tixSubwidgetRetCreate {sub ref} {
|
||||
set ::tixSRef($sub) $ref
|
||||
}
|
||||
|
||||
proc tixSubwidgetRetDelete {sub} {
|
||||
catch {unset ::tixSRef($sub)}
|
||||
}
|
||||
|
||||
proc tixListboxGetCurrent {listbox} {
|
||||
return [tixEvent flag V]
|
||||
}
|
||||
|
||||
|
||||
# tixSetMegaWidget --
|
||||
#
|
||||
# Associate a subwidget with its mega widget "owner". This is mainly
|
||||
# used when we add a new bindtag to a subwidget and we need to find out
|
||||
# the name of the mega widget inside the binding.
|
||||
#
|
||||
proc tixSetMegaWidget {w mega {type any}} {
|
||||
set ::tixMega($type,$w) $mega
|
||||
}
|
||||
|
||||
proc tixGetMegaWidget {w {type any}} {
|
||||
return $::tixMega($type,$w)
|
||||
}
|
||||
|
||||
proc tixUnsetMegaWidget {w} {
|
||||
if {[info exists ::tixMega($w)]} { unset ::tixMega($w) }
|
||||
}
|
||||
|
||||
# tixBusy : display busy cursors on a window
|
||||
#
|
||||
#
|
||||
# Should flush the event queue (but not do any idle tasks) before blocking
|
||||
# the target window (I am not sure if it is aready doing so )
|
||||
#
|
||||
# ToDo: should take some additional windows to raise
|
||||
#
|
||||
proc tixBusy {w flag {focuswin ""}} {
|
||||
|
||||
if {[info command tixInputOnly] == ""} {
|
||||
return
|
||||
}
|
||||
|
||||
global tixBusy
|
||||
set toplevel [winfo toplevel $w]
|
||||
|
||||
if {![info exists tixBusy(cursor)]} {
|
||||
set tixBusy(cursor) watch
|
||||
# set tixBusy(cursor) "[tix getbitmap hourglass] \
|
||||
# [string range [tix getbitmap hourglass.mask] 1 end]\
|
||||
# black white"
|
||||
}
|
||||
|
||||
if {$toplevel eq "."} {
|
||||
set inputonly0 .__tix__busy0
|
||||
set inputonly1 .__tix__busy1
|
||||
set inputonly2 .__tix__busy2
|
||||
set inputonly3 .__tix__busy3
|
||||
} else {
|
||||
set inputonly0 $toplevel.__tix__busy0
|
||||
set inputonly1 $toplevel.__tix__busy1
|
||||
set inputonly2 $toplevel.__tix__busy2
|
||||
set inputonly3 $toplevel.__tix__busy3
|
||||
}
|
||||
|
||||
if {![winfo exists $inputonly0]} {
|
||||
for {set i 0} {$i < 4} {incr i} {
|
||||
tixInputOnly [set inputonly$i] -cursor $tixBusy(cursor)
|
||||
}
|
||||
}
|
||||
|
||||
if {$flag eq "on"} {
|
||||
if {$focuswin != "" && [winfo id $focuswin] != 0} {
|
||||
if {[info exists tixBusy($focuswin,oldcursor)]} {
|
||||
return
|
||||
}
|
||||
set tixBusy($focuswin,oldcursor) [$focuswin cget -cursor]
|
||||
$focuswin config -cursor $tixBusy(cursor)
|
||||
|
||||
set x1 [expr {[winfo rootx $focuswin]-[winfo rootx $toplevel]}]
|
||||
set y1 [expr {[winfo rooty $focuswin]-[winfo rooty $toplevel]}]
|
||||
|
||||
set W [winfo width $focuswin]
|
||||
set H [winfo height $focuswin]
|
||||
set x2 [expr {$x1 + $W}]
|
||||
set y2 [expr {$y1 + $H}]
|
||||
|
||||
|
||||
if {$y1 > 0} {
|
||||
tixMoveResizeWindow $inputonly0 0 0 10000 $y1
|
||||
}
|
||||
if {$x1 > 0} {
|
||||
tixMoveResizeWindow $inputonly1 0 0 $x1 10000
|
||||
}
|
||||
tixMoveResizeWindow $inputonly2 0 $y2 10000 10000
|
||||
tixMoveResizeWindow $inputonly3 $x2 0 10000 10000
|
||||
|
||||
for {set i 0} {$i < 4} {incr i} {
|
||||
tixMapWindow [set inputonly$i]
|
||||
tixRaiseWindow [set inputonly$i]
|
||||
}
|
||||
tixFlushX $w
|
||||
} else {
|
||||
tixMoveResizeWindow $inputonly0 0 0 10000 10000
|
||||
tixMapWindow $inputonly0
|
||||
tixRaiseWindow $inputonly0
|
||||
}
|
||||
} else {
|
||||
tixUnmapWindow $inputonly0
|
||||
tixUnmapWindow $inputonly1
|
||||
tixUnmapWindow $inputonly2
|
||||
tixUnmapWindow $inputonly3
|
||||
|
||||
if {$focuswin != "" && [winfo id $focuswin] != 0} {
|
||||
if {[info exists tixBusy($focuswin,oldcursor)]} {
|
||||
$focuswin config -cursor $tixBusy($focuswin,oldcursor)
|
||||
if {[info exists tixBusy($focuswin,oldcursor)]} {
|
||||
unset tixBusy($focuswin,oldcursor)
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc tixOptionName {w} {
|
||||
return [string range $w 1 end]
|
||||
}
|
||||
|
||||
proc tixSetSilent {chooser value} {
|
||||
$chooser config -disablecallback true
|
||||
$chooser config -value $value
|
||||
$chooser config -disablecallback false
|
||||
}
|
||||
|
||||
# This command is useful if you want to ingore the arguments
|
||||
# passed by the -command or -browsecmd options of the Tix widgets. E.g
|
||||
#
|
||||
# tixFileSelectDialog .c -command "puts foo; tixBreak"
|
||||
#
|
||||
#
|
||||
proc tixBreak {args} {}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# tixDestroy -- deletes a Tix class object (not widget classes)
|
||||
#----------------------------------------------------------------------
|
||||
proc tixDestroy {w} {
|
||||
upvar #0 $w data
|
||||
|
||||
set destructor ""
|
||||
if {[info exists data(className)]} {
|
||||
catch {
|
||||
set destructor [tixGetMethod $w $data(className) Destructor]
|
||||
}
|
||||
}
|
||||
if {$destructor != ""} {
|
||||
$destructor $w
|
||||
}
|
||||
catch {rename $w ""}
|
||||
catch {unset data}
|
||||
return ""
|
||||
}
|
||||
|
||||
proc tixPushGrab {args} {
|
||||
global tix_priv
|
||||
|
||||
if {![info exists tix_priv(grab-list)]} {
|
||||
set tix_priv(grab-list) ""
|
||||
set tix_priv(grab-mode) ""
|
||||
set tix_priv(grab-nopush) ""
|
||||
}
|
||||
|
||||
set len [llength $args]
|
||||
if {$len == 1} {
|
||||
set opt ""
|
||||
set w [lindex $args 0]
|
||||
} elseif {$len == 2} {
|
||||
set opt [lindex $args 0]
|
||||
set w [lindex $args 1]
|
||||
} else {
|
||||
error "wrong # of arguments: tixPushGrab ?-global? window"
|
||||
}
|
||||
|
||||
# Not everyone will call tixPushGrab. If someone else has a grab already
|
||||
# save that one as well, so that we can restore that later
|
||||
#
|
||||
set last [lindex $tix_priv(grab-list) end]
|
||||
set current [grab current $w]
|
||||
|
||||
if {$current ne "" && $current ne $last} {
|
||||
# Someone called "grab" directly
|
||||
#
|
||||
lappend tix_priv(grab-list) $current
|
||||
lappend tix_priv(grab-mode) [grab status $current]
|
||||
lappend tix_priv(grab-nopush) 1
|
||||
}
|
||||
|
||||
# Now push myself into the stack
|
||||
#
|
||||
lappend tix_priv(grab-list) $w
|
||||
lappend tix_priv(grab-mode) $opt
|
||||
lappend tix_priv(grab-nopush) 0
|
||||
|
||||
if {$opt eq "-global"} {
|
||||
grab -global $w
|
||||
} else {
|
||||
grab $w
|
||||
}
|
||||
}
|
||||
|
||||
proc tixPopGrab {} {
|
||||
global tix_priv
|
||||
|
||||
if {![info exists tix_priv(grab-list)]} {
|
||||
set tix_priv(grab-list) ""
|
||||
set tix_priv(grab-mode) ""
|
||||
set tix_priv(grab-nopush) ""
|
||||
}
|
||||
|
||||
set len [llength $tix_priv(grab-list)]
|
||||
if {$len <= 0} {
|
||||
error "no window is grabbed by tixGrab"
|
||||
}
|
||||
|
||||
set w [lindex $tix_priv(grab-list) end]
|
||||
grab release $w
|
||||
|
||||
if {$len > 1} {
|
||||
set tix_priv(grab-list) [lrange $tix_priv(grab-list) 0 end-1]
|
||||
set tix_priv(grab-mode) [lrange $tix_priv(grab-mode) 0 end-1]
|
||||
set tix_priv(grab-nopush) [lrange $tix_priv(grab-nopush) 0 end-1]
|
||||
|
||||
set w [lindex $tix_priv(grab-list) end]
|
||||
set m [lindex $tix_priv(grab-list) end]
|
||||
set np [lindex $tix_priv(grab-nopush) end]
|
||||
|
||||
if {$np == 1} {
|
||||
# We have a grab set by "grab"
|
||||
#
|
||||
set len [llength $tix_priv(grab-list)]
|
||||
|
||||
if {$len > 1} {
|
||||
set tix_priv(grab-list) [lrange $tix_priv(grab-list) 0 end-1]
|
||||
set tix_priv(grab-mode) [lrange $tix_priv(grab-mode) 0 end-1]
|
||||
set tix_priv(grab-nopush) \
|
||||
[lrange $tix_priv(grab-nopush) 0 end-1]
|
||||
} else {
|
||||
set tix_priv(grab-list) ""
|
||||
set tix_priv(grab-mode) ""
|
||||
set tix_priv(grab-nopush) ""
|
||||
}
|
||||
}
|
||||
|
||||
if {$m == "-global"} {
|
||||
grab -global $w
|
||||
} else {
|
||||
grab $w
|
||||
}
|
||||
} else {
|
||||
set tix_priv(grab-list) ""
|
||||
set tix_priv(grab-mode) ""
|
||||
set tix_priv(grab-nopush) ""
|
||||
}
|
||||
}
|
||||
|
||||
proc tixWithinWindow {wid rootX rootY} {
|
||||
set wc [winfo containing $rootX $rootY]
|
||||
if {$wid eq $wc} { return 1 }
|
||||
|
||||
# no see if it is an enclosing parent
|
||||
set rx1 [winfo rootx $wid]
|
||||
set ry1 [winfo rooty $wid]
|
||||
set rw [winfo width $wid]
|
||||
set rh [winfo height $wid]
|
||||
set rx2 [expr {$rx1+$rw}]
|
||||
set ry2 [expr {$ry1+$rh}]
|
||||
|
||||
if {$rootX >= $rx1 && $rootX < $rx2 && $rootY >= $ry1 && $rootY < $ry2} {
|
||||
return 1
|
||||
} else {
|
||||
return 0
|
||||
}
|
||||
}
|
||||
|
||||
proc tixWinWidth {w} {
|
||||
set W [winfo width $w]
|
||||
set bd [expr {[$w cget -bd] + [$w cget -highlightthickness]}]
|
||||
|
||||
return [expr {$W - 2*$bd}]
|
||||
}
|
||||
|
||||
proc tixWinHeight {w} {
|
||||
set H [winfo height $w]
|
||||
set bd [expr {[$w cget -bd] + [$w cget -highlightthickness]}]
|
||||
|
||||
return [expr {$H - 2*$bd}]
|
||||
}
|
||||
|
||||
# junk?
|
||||
#
|
||||
proc tixWinCmd {w} {
|
||||
return [winfo command $w]
|
||||
}
|
||||
Reference in New Issue
Block a user