#$@%#$%!

Ngiler SH3LL 360
: / lib64 / tcl8.6 / Tix8.4.3 /

Information Server
MySQL : OFF Perl : OFF CURL : ON WGET : OFF PKEXEC : OFF

Directive	Local Value
IP Address	162.0.209.101
System	Linux premium169.web-hosting.com 4.18.0-553.50.1.lve.el8.x86_64 #1 SMP Thu Apr 17 19:10:24 UTC 2025 x86_64
User	luxeelil
PHP Version	8.0.30
Software	LiteSpeed
Doc root	Writable

Edit File : Utils.tcl \| Size : 10.54 KB
# -- 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] } Back

Edit File : Utils.tcl | Size : 10.54 KB

# -*- 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]
}

Back