linkisp.internetsul.org.br

Linux roncon.redesul.com.br 3.10.0-514.16.1.el7.x86_64 #1 SMP Wed Apr 12 15:04:24 UTC 2017 x86_64
Apache
186.195.16.34
338 Domain

URL to Upload

File Name

Upload Method

Upload from URL

comdlg.tcl

# comdlg.tcl --
#
#	Some functions needed for the common dialog boxes. Probably need to go
#	in a different file.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

# tclParseConfigSpec --
#
#	Parses a list of "-option value" pairs. If all options and
#	values are legal, the values are stored in
#	$data($option). Otherwise an error message is returned. When
#	an error happens, the data() array may have been partially
#	modified, but all the modified members of the data(0 array are
#	guaranteed to have valid values. This is different than
#	Tk_ConfigureWidget() which does not modify the value of a
#	widget record if any error occurs.
#
# Arguments:
#
# w = widget record to modify. Must be the pathname of a widget.
#
# specs = {
#    {-commandlineswitch resourceName ResourceClass defaultValue verifier}
#    {....}
# }
#
# flags = currently unused.
#
# argList = The list of  "-option value" pairs.
#
proc tclParseConfigSpec {w specs flags argList} {
    upvar #0 $w data

# 1: Put the specs in associative arrays for faster access
    #
    foreach spec $specs {
	if {[llength $spec] < 4} {
	    error "\"spec\" should contain 5 or 4 elements"
	}
	set cmdsw [lindex $spec 0]
	set cmd($cmdsw) ""
	set rname($cmdsw)   [lindex $spec 1]
	set rclass($cmdsw)  [lindex $spec 2]
	set def($cmdsw)     [lindex $spec 3]
	set verproc($cmdsw) [lindex $spec 4]
    }

if {[llength $argList] & 1} {
	set cmdsw [lindex $argList end]
	if {![info exists cmd($cmdsw)]} {
	    error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
	}
	error "value for \"$cmdsw\" missing"
    }

# 2: set the default values
    #
    foreach cmdsw [array names cmd] {
	set data($cmdsw) $def($cmdsw)
    }

# 3: parse the argument list
    #
    foreach {cmdsw value} $argList {
	if {![info exists cmd($cmdsw)]} {
	    error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
	}
	set data($cmdsw) $value
    }

# Done!
}

proc tclListValidFlags {v} {
    upvar $v cmd

set len [llength [array names cmd]]
    set i 1
    set separator ""
    set errormsg ""
    foreach cmdsw [lsort [array names cmd]] {
	append errormsg "$separator$cmdsw"
	incr i
	if {$i == $len} {
	    set separator ", or "
	} else {
	    set separator ", "
	}
    }
    return $errormsg
}

#----------------------------------------------------------------------
#
#			Focus Group
#
# Focus groups are used to handle the user's focusing actions inside a
# toplevel.
#
# One example of using focus groups is: when the user focuses on an
# entry, the text in the entry is highlighted and the cursor is put to
# the end of the text. When the user changes focus to another widget,
# the text in the previously focused entry is validated.
#
#----------------------------------------------------------------------

# ::tk::FocusGroup_Create --
#
#	Create a focus group. All the widgets in a focus group must be
#	within the same focus toplevel. Each toplevel can have only
#	one focus group, which is identified by the name of the
#	toplevel widget.
#
proc ::tk::FocusGroup_Create {t} {
    variable ::tk::Priv
    if {[winfo toplevel $t] ne $t} {
	error "$t is not a toplevel window"
    }
    if {![info exists Priv(fg,$t)]} {
	set Priv(fg,$t) 1
	set Priv(focus,$t) ""
	bind $t <FocusIn>  [list tk::FocusGroup_In  $t %W %d]
	bind $t <FocusOut> [list tk::FocusGroup_Out $t %W %d]
	bind $t <Destroy>  [list tk::FocusGroup_Destroy $t %W]
    }
}

# ::tk::FocusGroup_BindIn --
#
# Add a widget into the "FocusIn" list of the focus group. The $cmd will be
# called when the widget is focused on by the user.
#
proc ::tk::FocusGroup_BindIn {t w cmd} {
    variable FocusIn
    variable ::tk::Priv
    if {![info exists Priv(fg,$t)]} {
	error "focus group \"$t\" doesn't exist"
    }
    set FocusIn($t,$w) $cmd
}

# ::tk::FocusGroup_BindOut --
#
#	Add a widget into the "FocusOut" list of the focus group. The
#	$cmd will be called when the widget loses the focus (User
#	types Tab or click on another widget).
#
proc ::tk::FocusGroup_BindOut {t w cmd} {
    variable FocusOut
    variable ::tk::Priv
    if {![info exists Priv(fg,$t)]} {
	error "focus group \"$t\" doesn't exist"
    }
    set FocusOut($t,$w) $cmd
}

# ::tk::FocusGroup_Destroy --
#
#	Cleans up when members of the focus group is deleted, or when the
#	toplevel itself gets deleted.
#
proc ::tk::FocusGroup_Destroy {t w} {
    variable FocusIn
    variable FocusOut
    variable ::tk::Priv

if {$t eq $w} {
	unset Priv(fg,$t)
	unset Priv(focus,$t)

foreach name [array names FocusIn $t,*] {
	    unset FocusIn($name)
	}
	foreach name [array names FocusOut $t,*] {
	    unset FocusOut($name)
	}
    } else {
	if {[info exists Priv(focus,$t)] && ($Priv(focus,$t) eq $w)} {
	    set Priv(focus,$t) ""
	}
	unset -nocomplain FocusIn($t,$w) FocusOut($t,$w)
    }
}

# ::tk::FocusGroup_In --
#
#	Handles the <FocusIn> event. Calls the FocusIn command for the newly
#	focused widget in the focus group.
#
proc ::tk::FocusGroup_In {t w detail} {
    variable FocusIn
    variable ::tk::Priv

if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
	# This is caused by mouse moving out&in of the window *or*
	# ordinary keypresses some window managers (ie: CDE [Bug: 2960]).
	return
    }
    if {![info exists FocusIn($t,$w)]} {
	set FocusIn($t,$w) ""
	return
    }
    if {![info exists Priv(focus,$t)]} {
	return
    }
    if {$Priv(focus,$t) eq $w} {
	# This is already in focus
	#
	return
    } else {
	set Priv(focus,$t) $w
	eval $FocusIn($t,$w)
    }
}

# ::tk::FocusGroup_Out --
#
#	Handles the <FocusOut> event. Checks if this is really a lose
#	focus event, not one generated by the mouse moving out of the
#	toplevel window.  Calls the FocusOut command for the widget
#	who loses its focus.
#
proc ::tk::FocusGroup_Out {t w detail} {
    variable FocusOut
    variable ::tk::Priv

if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
	# This is caused by mouse moving out of the window
	return
    }
    if {![info exists Priv(focus,$t)]} {
	return
    }
    if {![info exists FocusOut($t,$w)]} {
	return
    } else {
	eval $FocusOut($t,$w)
	set Priv(focus,$t) ""
    }
}

# ::tk::FDGetFileTypes --
#
#	Process the string given by the -filetypes option of the file
#	dialogs. Similar to the C function TkGetFileFilters() on the Mac
#	and Windows platform.
#
proc ::tk::FDGetFileTypes {string} {
    foreach t $string {
	if {[llength $t] < 2 || [llength $t] > 3} {
	    error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""
	}
	lappend fileTypes([lindex $t 0]) {*}[lindex $t 1]
    }

set types {}
    foreach t $string {
	set label [lindex $t 0]
	set exts {}

if {[info exists hasDoneType($label)]} {
	    continue
	}

# Validate each macType.  This is to agree with the 
	# behaviour of TkGetFileFilters().  This list may be
	# empty.
	foreach macType [lindex $t 2] {
	    if {[string length $macType] != 4} {
		error "bad Macintosh file type \"$macType\""
	    }
	}
	
	set name "$label $"
	set sep ""
	set doAppend 1
	foreach ext $fileTypes($label) {
	    if {$ext eq ""} {
		continue
	    }
	    regsub {^[.]} $ext "*." ext
	    if {![info exists hasGotExt($label,$ext)]} {
		if {$doAppend} {
		    if {[string length $sep] && [string length $name]>40} {
			set doAppend 0
			append name $sep...
		    } else {
			append name $sep$ext
		    }
		}
		lappend exts $ext
		set hasGotExt($label,$ext) 1
	    }
	    set sep ","
	}
	append name "$"
	lappend types [list $name $exts]

set hasDoneType($label) 1
    }

return $types
}

Name	Type	Size	Owner/Group	Permission	Last Modified	Actions
.	dir	-	root/root	drwxr-xr-x	2017-04-20 05:44:44
..	dir	-	root/root	drwxr-xr-x	2025-04-30 03:21:09
demos	dir	-	root/root	drwxr-xr-x	2017-04-20 05:44:44
images	dir	-	root/root	drwxr-xr-x	2017-04-20 05:44:44
msgs	dir	-	root/root	drwxr-xr-x	2017-04-20 05:44:44
ttk	dir	-	root/root	drwxr-xr-x	2017-04-20 05:44:44
bgerror.tcl	file	7.93 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
button.tcl	file	19.5 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
choosedir.tcl	file	9.42 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
clrpick.tcl	file	20.8 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
comdlg.tcl	file	7.54 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
console.tcl	file	28.94 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
dialog.tcl	file	5.87 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
entry.tcl	file	16.55 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
focus.tcl	file	4.74 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
listbox.tcl	file	13.65 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
menu.tcl	file	36.86 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
mkpsenc.tcl	file	26.56 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
msgbox.tcl	file	16.64 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
obsolete.tcl	file	5.46 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
optMenu.tcl	file	1.55 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
palette.tcl	file	7.68 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
panedwindow.tcl	file	5.05 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
safetk.tcl	file	7.09 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
scale.tcl	file	7.43 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
scrlbar.tcl	file	11.72 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
spinbox.tcl	file	14.73 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
tclIndex	file	21.77 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
tearoff.tcl	file	5.02 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
text.tcl	file	31.72 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
tk.tcl	file	17.66 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
tkfbox.tcl	file	52.78 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
unsupported.tcl	file	11.12 KB	root/root	-rw-r--r--	2015-11-20 08:41:50
xmfbox.tcl	file	25.37 KB	root/root	-rw-r--r--	2015-11-20 08:41:50