diff options
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2')
-rw-r--r-- | systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itcl.tcl | 151 | ||||
-rwxr-xr-x | systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itcl422.dll | bin | 560070 -> 0 bytes | |||
-rw-r--r-- | systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itclConfig.sh | 67 | ||||
-rw-r--r-- | systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itclHullCmds.tcl | 562 | ||||
-rw-r--r-- | systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itclWidget.tcl | 447 | ||||
-rw-r--r-- | systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/pkgIndex.tcl | 14 |
6 files changed, 0 insertions, 1241 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itcl.tcl b/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itcl.tcl deleted file mode 100644 index 15ca2200f4..0000000000 --- a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itcl.tcl +++ /dev/null @@ -1,151 +0,0 @@ -# -# itcl.tcl -# ---------------------------------------------------------------------- -# Invoked automatically upon startup to customize the interpreter -# for [incr Tcl]. -# ---------------------------------------------------------------------- -# AUTHOR: Michael J. McLennan -# Bell Labs Innovations for Lucent Technologies -# mmclennan@lucent.com -# http://www.tcltk.com/itcl -# ---------------------------------------------------------------------- -# Copyright (c) 1993-1998 Lucent Technologies, Inc. -# ====================================================================== -# See the file "license.terms" for information on usage and -# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -proc ::itcl::delete_helper { name args } { - ::itcl::delete object $name -} - -# ---------------------------------------------------------------------- -# USAGE: local <className> <objName> ?<arg> <arg>...? -# -# Creates a new object called <objName> in class <className>, passing -# the remaining <arg>'s to the constructor. Unlike the usual -# [incr Tcl] objects, however, an object created by this procedure -# will be automatically deleted when the local call frame is destroyed. -# This command is useful for creating objects that should only remain -# alive until a procedure exits. -# ---------------------------------------------------------------------- -proc ::itcl::local {class name args} { - set ptr [uplevel [list $class $name] $args] - uplevel [list set itcl-local-$ptr $ptr] - set cmd [uplevel namespace which -command $ptr] - uplevel [list trace variable itcl-local-$ptr u \ - "::itcl::delete_helper $cmd"] - return $ptr -} - -# ---------------------------------------------------------------------- -# auto_mkindex -# ---------------------------------------------------------------------- -# Define Itcl commands that will be recognized by the auto_mkindex -# parser in Tcl... -# - -# -# USAGE: itcl::class name body -# Adds an entry for the given class declaration. -# -foreach __cmd {itcl::class class itcl::type type ictl::widget widget itcl::widgetadaptor widgetadaptor itcl::extendedclass extendedclass} { - auto_mkindex_parser::command $__cmd {name body} { - variable index - variable scriptFile - append index "set [list auto_index([fullname $name])]" - append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n" - - variable parser - variable contextStack - set contextStack [linsert $contextStack 0 $name] - $parser eval $body - set contextStack [lrange $contextStack 1 end] - } -} - -# -# USAGE: itcl::body name arglist body -# Adds an entry for the given method/proc body. -# -foreach __cmd {itcl::body body} { - auto_mkindex_parser::command $__cmd {name arglist body} { - variable index - variable scriptFile - append index "set [list auto_index([fullname $name])]" - append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n" - } -} - -# -# USAGE: itcl::configbody name arglist body -# Adds an entry for the given method/proc body. -# -foreach __cmd {itcl::configbody configbody} { - auto_mkindex_parser::command $__cmd {name body} { - variable index - variable scriptFile - append index "set [list auto_index([fullname $name])]" - append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n" - } -} - -# -# USAGE: ensemble name ?body? -# Adds an entry to the auto index list for the given ensemble name. -# -foreach __cmd {itcl::ensemble ensemble} { - auto_mkindex_parser::command $__cmd {name {body ""}} { - variable index - variable scriptFile - append index "set [list auto_index([fullname $name])]" - append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n" - } -} - -# -# USAGE: public arg ?arg arg...? -# protected arg ?arg arg...? -# private arg ?arg arg...? -# -# Evaluates the arguments as commands, so we can recognize proc -# declarations within classes. -# -foreach __cmd {public protected private} { - auto_mkindex_parser::command $__cmd {args} { - variable parser - $parser eval $args - } -} - -# SF bug #246 unset variable __cmd to avoid problems in user programs!! -unset __cmd - -# ---------------------------------------------------------------------- -# auto_import -# ---------------------------------------------------------------------- -# This procedure overrides the usual "auto_import" function in the -# Tcl library. It is invoked during "namespace import" to make see -# if the imported commands reside in an autoloaded library. If so, -# stubs are created to represent the commands. Executing a stub -# later on causes the real implementation to be autoloaded. -# -# Arguments - -# pattern The pattern of commands being imported (like "foo::*") -# a canonical namespace as returned by [namespace current] - -proc auto_import {pattern} { - global auto_index - - set ns [uplevel namespace current] - set patternList [auto_qualify $pattern $ns] - - auto_load_index - - foreach pattern $patternList { - foreach name [array names auto_index $pattern] { - if {"" == [info commands $name]} { - ::itcl::import::stub create $name - } - } - } -} diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itcl422.dll b/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itcl422.dll Binary files differdeleted file mode 100755 index bf25605665..0000000000 --- a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itcl422.dll +++ /dev/null diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itclConfig.sh b/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itclConfig.sh deleted file mode 100644 index 00e147b870..0000000000 --- a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itclConfig.sh +++ /dev/null @@ -1,67 +0,0 @@ -# itclConfig.sh -- -# -# This shell script (for sh) is generated automatically by Itcl's -# configure script. It will create shell variables for most of -# the configuration options discovered by the configure script. -# This script is intended to be included by the configure scripts -# for Itcl extensions so that they don't have to figure this all -# out for themselves. This file does not duplicate information -# already provided by tclConfig.sh, so you may need to use that -# file in addition to this one. -# -# The information in this file is specific to a single platform. - -# Itcl's version number. -itcl_VERSION='4.2.2' -ITCL_VERSION='4.2.2' - -# The name of the Itcl library (may be either a .a file or a shared library): -itcl_LIB_FILE=itcl422.dll -ITCL_LIB_FILE=itcl422.dll - -# String to pass to linker to pick up the Itcl library from its -# build directory. -itcl_BUILD_LIB_SPEC='-L/tmp/siepo/tcl8.6.12/win/pkgs/itcl4.2.2 -litcl422' -ITCL_BUILD_LIB_SPEC='-L/tmp/siepo/tcl8.6.12/win/pkgs/itcl4.2.2 -litcl422' - -# String to pass to linker to pick up the Itcl library from its -# installed directory. -itcl_LIB_SPEC='-L/tmp/tltcl/lib/itcl4.2.2 -litcl422' -ITCL_LIB_SPEC='-L/tmp/tltcl/lib/itcl4.2.2 -litcl422' - -# The name of the Itcl stub library (a .a file): -itcl_STUB_LIB_FILE=libitclstub422.a -ITCL_STUB_LIB_FILE=libitclstub422.a - -# String to pass to linker to pick up the Itcl stub library from its -# build directory. -itcl_BUILD_STUB_LIB_SPEC='-L/tmp/siepo/tcl8.6.12/win/pkgs/itcl4.2.2 -litclstub422' -ITCL_BUILD_STUB_LIB_SPEC='-L/tmp/siepo/tcl8.6.12/win/pkgs/itcl4.2.2 -litclstub422' - -# String to pass to linker to pick up the Itcl stub library from its -# installed directory. -itcl_STUB_LIB_SPEC='-L/tmp/tltcl/lib/itcl4.2.2 -litclstub422' -ITCL_STUB_LIB_SPEC='-L/tmp/tltcl/lib/itcl4.2.2 -litclstub422' - -# String to pass to linker to pick up the Itcl stub library from its -# build directory. -itcl_BUILD_STUB_LIB_PATH='/tmp/siepo/tcl8.6.12/win/pkgs/itcl4.2.2/libitclstub422.a' -ITCL_BUILD_STUB_LIB_PATH='/tmp/siepo/tcl8.6.12/win/pkgs/itcl4.2.2/libitclstub422.a' - -# String to pass to linker to pick up the Itcl stub library from its -# installed directory. -itcl_STUB_LIB_PATH='/tmp/tltcl/lib/itcl4.2.2/libitclstub422.a' -ITCL_STUB_LIB_PATH='/tmp/tltcl/lib/itcl4.2.2/libitclstub422.a' - -# Location of the top-level source directories from which [incr Tcl] -# was built. This is the directory that contains generic, unix, etc. -# If [incr Tcl] was compiled in a different place than the directory -# containing the source files, this points to the location of the sources, -# not the location where [incr Tcl] was compiled. -itcl_SRC_DIR='/tmp/siepo/tcl8.6.12/pkgs/itcl4.2.2' -ITCL_SRC_DIR='/tmp/siepo/tcl8.6.12/pkgs/itcl4.2.2' - -# String to pass to the compiler so that an extension can -# find installed Itcl headers. -itcl_INCLUDE_SPEC='-I/tmp/siepo/tcl8.6.12/pkgs/itcl4.2.2/generic' -ITCL_INCLUDE_SPEC='-I/tmp/siepo/tcl8.6.12/pkgs/itcl4.2.2/generic' diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itclHullCmds.tcl b/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itclHullCmds.tcl deleted file mode 100644 index 282041187c..0000000000 --- a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itclHullCmds.tcl +++ /dev/null @@ -1,562 +0,0 @@ -# -# itclHullCmds.tcl -# ---------------------------------------------------------------------- -# Invoked automatically upon startup to customize the interpreter -# for [incr Tcl] when one of setupcomponent or createhull is called. -# ---------------------------------------------------------------------- -# AUTHOR: Arnulf P. Wiedemann -# -# ---------------------------------------------------------------------- -# Copyright (c) 2008 Arnulf P. Wiedemann -# ====================================================================== -# See the file "license.terms" for information on usage and -# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -package require Tk 8.6 - -namespace eval ::itcl::internal::commands { - -# ======================= widgetDeleted =========================== - -proc widgetDeleted {oldName newName op} { - # The widget is beeing deleted, so we have to delete the object - # which had the widget as itcl_hull too! - # We have to get the real name from for example - # ::itcl::internal::widgets::hull1.lw - # we need only .lw here - -#puts stderr "widgetDeleted!$oldName!$newName!$op!" - set cmdName [namespace tail $oldName] - set flds [split $cmdName {.}] - set cmdName .[join [lrange $flds 1 end] {.}] -#puts stderr "DELWIDGET![namespace current]!$cmdName![::info command $cmdName]!" - rename $cmdName {} -} - -} - -namespace eval ::itcl::builtin { - -# ======================= createhull =========================== -# the hull widget is a tk widget which is the (mega) widget handled behind the itcl -# extendedclass/itcl widget. -# It is created be renaming the itcl class object to a temporary name <itcl object name>_ -# creating the widget with the -# appropriate options and the installing that as the "hull" widget (the container) -# All the options in args and the options delegated to component itcl_hull are used -# Then a unique name (hull_widget_name) in the itcl namespace is created for widget: -# ::itcl::internal::widgets::hull<unique number><namespace tail path> -# and widget is renamed to that name -# Finally the <itcl object name>_ is renamed to the original <itcl object name> again -# Component itcl_hull is created if not existent -# itcl_hull is set to the hull_widget_name and the <itcl object name> -# is returned to the caller -# ============================================================== - -proc createhull {widget_type path args} { - variable hullCount - upvar this this - upvar win win - - -#puts stderr "il-1![::info level -1]!$this!" -#puts stderr "createhull!$widget_type!$path!$args!$this![::info command $this]!" -#puts stderr "ns1![uplevel 1 namespace current]!" -#puts stderr "ns2![uplevel 2 namespace current]!" -#puts stderr "ns3![uplevel 3 namespace current]!" -#puts stderr "level-1![::info level -1]!" -#puts stderr "level-2![::info level -2]!" -# set my_this [namespace tail $this] - set my_this $this - set tmp $my_this -#puts stderr "II![::info command $this]![::info command $tmp]!" -#puts stderr "rename1!rename $my_this ${tmp}_!" - rename ::$my_this ${tmp}_ - set options [list] - foreach {option_name value} $args { - switch -glob -- $option_name { - -class { - lappend options $option_name [namespace tail $value] - } - -* { - lappend options $option_name $value - } - default { - return -code error "bad option name\"$option_name\" options must start with a \"-\"" - } - } - } - set my_win [namespace tail $path] - set cmd [list $widget_type $my_win] -#puts stderr "my_win!$my_win!cmd!$cmd!$path!" - if {[llength $options] > 0} { - lappend cmd {*}$options - } - set widget [uplevel 1 $cmd] -#puts stderr "widget!$widget!" - trace add command $widget delete ::itcl::internal::commands::widgetDeleted - set opts [uplevel 1 info delegated options] - foreach entry $opts { - foreach {optName compName} $entry break - if {$compName eq "itcl_hull"} { - set optInfos [uplevel 1 info delegated option $optName] - set realOptName [lindex $optInfos 4] - # strip off the "-" at the beginning - set myOptName [string range $realOptName 1 end] - set my_opt_val [option get $my_win $myOptName *] - if {$my_opt_val ne ""} { - $my_win configure -$myOptName $my_opt_val - } - } - } - set idx 1 - while {1} { - set widgetName ::itcl::internal::widgets::hull${idx}$my_win -#puts stderr "widgetName!$widgetName!" - if {[string length [::info command $widgetName]] == 0} { - break - } - incr idx - } -#puts stderr "rename2!rename $widget $widgetName!" - set dorename 0 - rename $widget $widgetName -#puts stderr "rename3!rename ${tmp}_ $tmp![::info command ${tmp}_]!my_this!$my_this!" - rename ${tmp}_ ::$tmp - set exists [uplevel 1 ::info exists itcl_hull] - if {!$exists} { - # that does not yet work, beacause of problems with resolving - ::itcl::addcomponent $my_this itcl_hull - } - upvar itcl_hull itcl_hull - ::itcl::setcomponent $my_this itcl_hull $widgetName -#puts stderr "IC![::info command $my_win]!" - set exists [uplevel 1 ::info exists itcl_interior] - if {!$exists} { - # that does not yet work, beacause of problems with resolving - ::itcl::addcomponent $this itcl_interior - } - upvar itcl_interior itcl_interior - set itcl_interior $my_win -#puts stderr "hull end!win!$win!itcl_hull!$itcl_hull!itcl_interior!$itcl_interior!" - return $my_win -} - -# ======================= addToItclOptions =========================== - -proc addToItclOptions {my_class my_win myOptions argsDict} { - upvar win win - upvar itcl_hull itcl_hull - - set opt_lst [list configure] - foreach opt [lsort $myOptions] { -#puts stderr "IOPT!$opt!$my_class!$my_win![::itcl::is class $my_class]!" - set isClass [::itcl::is class $my_class] - set found 0 - if {$isClass} { - if {[catch { - set resource [namespace eval $my_class info option $opt -resource] - set class [namespace eval $my_class info option $opt -class] - set default_val [uplevel 2 info option $opt -default] - set found 1 - } msg]} { -# puts stderr "MSG!$opt!$my_class!$msg!" - } - } else { - set tmp_win [uplevel #0 $my_class .___xx] - - set my_info [$tmp_win configure $opt] - set resource [lindex $my_info 1] - set class [lindex $my_info 2] - set default_val [lindex $my_info 3] - uplevel #0 destroy $tmp_win - set found 1 - } - if {$found} { - if {[catch { - set val [uplevel #0 ::option get $win $resource $class] - } msg]} { - set val "" - } - if {[::dict exists $argsDict $opt]} { - # we have an explicitly set option - set val [::dict get $argsDict $opt] - } else { - if {[string length $val] == 0} { - set val $default_val - } - } - set ::itcl::internal::variables::${my_win}::itcl_options($opt) $val - set ::itcl::internal::variables::${my_win}::__itcl_option_infos($opt) [list $resource $class $default_val] -#puts stderr "OPT1!$opt!$val!" -# uplevel 1 [list set itcl_options($opt) [list $val]] - if {[catch {uplevel 1 $win configure $opt [list $val]} msg]} { -#puts stderr "addToItclOptions ERR!$msg!$my_class!$win!configure!$opt!$val!" - } - } - } -} - -# ======================= setupcomponent =========================== - -proc setupcomponent {comp using widget_type path args} { - upvar this this - upvar win win - upvar itcl_hull itcl_hull - -#puts stderr "setupcomponent!$comp!$widget_type!$path!$args!$this!$win!$itcl_hull!" -#puts stderr "CONT![uplevel 1 info context]!" -#puts stderr "ns1![uplevel 1 namespace current]!" -#puts stderr "ns2![uplevel 2 namespace current]!" -#puts stderr "ns3![uplevel 3 namespace current]!" - set my_comp_object [lindex [uplevel 1 info context] 1] - if {[::info exists ::itcl::internal::component_objects($my_comp_object)]} { - set my_comp_object [set ::itcl::internal::component_objects($my_comp_object)] - } else { - set ::itcl::internal::component_objects($path) $my_comp_object - } - set options [list] - foreach {option_name value} $args { - switch -glob -- $option_name { - -* { - lappend options $option_name $value - } - default { - return -code error "bad option name\"$option_name\" options must start with a \"-\"" - } - } - } - if {[llength $args]} { - set argsDict [dict create {*}$args] - } else { - set argsDict [dict create] - } - set cmd [list $widget_type $path] - if {[llength $options] > 0} { - lappend cmd {*}$options - } -#puts stderr "cmd0![::info command $widget_type]!$path![::info command $path]!" -#puts stderr "cmd1!$cmd!" -# set my_comp [uplevel 3 $cmd] - set my_comp [uplevel #0 $cmd] -#puts stderr 111![::info command $path]! - ::itcl::setcomponent $this $comp $my_comp - set opts [uplevel 1 info delegated options] - foreach entry $opts { - foreach {optName compName} $entry break - if {$compName eq $my_comp} { - set optInfos [uplevel 1 info delegated option $optName] - set realOptName [lindex $optInfos 4] - # strip off the "-" at the beginning - set myOptName [string range $realOptName 1 end] - set my_opt_val [option get $my_win $myOptName *] - if {$my_opt_val ne ""} { - $my_comp configure -$myOptName $my_opt_val - } - } - } - set my_class $widget_type - set my_parent_class [uplevel 1 namespace current] - if {[catch { - set myOptions [namespace eval $my_class {info classoptions}] - } msg]} { - set myOptions [list] - } - foreach entry [$path configure] { - foreach {opt dummy1 dummy2 dummy3} $entry break - lappend myOptions $opt - } -#puts stderr "OPTS!$myOptions!" - addToItclOptions $widget_type $my_comp_object $myOptions $argsDict -#puts stderr END!$path![::info command $path]! -} - -proc itcl_initoptions {args} { -puts stderr "ITCL_INITOPT!$args!" -} - -# ======================= initoptions =========================== - -proc initoptions {args} { - upvar win win - upvar itcl_hull itcl_hull - upvar itcl_option_components itcl_option_components - -#puts stderr "INITOPT!!$win!" - if {[llength $args]} { - set argsDict [dict create {*}$args] - } else { - set argsDict [dict create] - } - set my_class [uplevel 1 namespace current] - set myOptions [namespace eval $my_class {info classoptions}] - if {[dict exists $::itcl::internal::dicts::classComponents $my_class]} { - set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class] -# set myOptions [lsort -unique [namespace eval $my_class {info options}]] - foreach comp [uplevel 1 info components] { - if {[dict exists $class_info_dict $comp -keptoptions]} { - foreach my_opt [dict get $class_info_dict $comp -keptoptions] { - if {[lsearch $myOptions $my_opt] < 0} { -#puts stderr "KEOPT!$my_opt!" - lappend myOptions $my_opt - } - } - } - } - } else { - set class_info_dict [list] - } -#puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!" - set opt_lst [list configure] - set my_win $win - foreach opt [lsort $myOptions] { - set found 0 - if {[catch { - set resource [uplevel 1 info option $opt -resource] - set class [uplevel 1 info option $opt -class] - set default_val [uplevel 1 info option $opt -default] - set found 1 - } msg]} { -# puts stderr "MSG!$opt!$msg!" - } -#puts stderr "OPT!$opt!$found!" - if {$found} { - if {[catch { - set val [uplevel #0 ::option get $my_win $resource $class] - } msg]} { - set val "" - } - if {[::dict exists $argsDict $opt]} { - # we have an explicitly set option - set val [::dict get $argsDict $opt] - } else { - if {[string length $val] == 0} { - set val $default_val - } - } - set ::itcl::internal::variables::${win}::itcl_options($opt) $val - set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val] -#puts stderr "OPT1!$opt!$val!" -# uplevel 1 [list set itcl_options($opt) [list $val]] - if {[catch {uplevel 1 $my_win configure $opt [list $val]} msg]} { -puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!" - } - } - foreach comp [dict keys $class_info_dict] { -#puts stderr "OPT1!$opt!$comp![dict get $class_info_dict $comp]!" - if {[dict exists $class_info_dict $comp -keptoptions]} { - if {[lsearch [dict get $class_info_dict $comp -keptoptions] $opt] >= 0} { - if {$found == 0} { - # we use the option value of the first component for setting - # the option, as the components are traversed in the dict - # depending on the ordering of the component creation!! - set my_info [uplevel 1 \[set $comp\] configure $opt] - set resource [lindex $my_info 1] - set class [lindex $my_info 2] - set default_val [lindex $my_info 3] - set found 2 - set val [uplevel #0 ::option get $my_win $resource $class] - if {[::dict exists $argsDict $opt]} { - # we have an explicitly set option - set val [::dict get $argsDict $opt] - } else { - if {[string length $val] == 0} { - set val $default_val - } - } -#puts stderr "OPT2!$opt!$val!" - set ::itcl::internal::variables::${win}::itcl_options($opt) $val - set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val] -# uplevel 1 [list set itcl_options($opt) [list $val]] - } - if {[catch {uplevel 1 \[set $comp\] configure $opt [list $val]} msg]} { -puts stderr "initoptions ERR2!$msg!$my_class!$comp!configure!$opt!$val!" - } - if {![uplevel 1 info exists itcl_option_components($opt)]} { - set itcl_option_components($opt) [list] - } - if {[lsearch [set itcl_option_components($opt)] $comp] < 0} { - if {![catch { - set optval [uplevel 1 [list set itcl_options($opt)]] - } msg3]} { - uplevel 1 \[set $comp\] configure $opt $optval - } - lappend itcl_option_components($opt) $comp - } - } - } - } - } -# uplevel 1 $opt_lst -} - -# ======================= setoptions =========================== - -proc setoptions {args} { - -#puts stderr "setOPT!!$args!" - if {[llength $args]} { - set argsDict [dict create {*}$args] - } else { - set argsDict [dict create] - } - set my_class [uplevel 1 namespace current] - set myOptions [namespace eval $my_class {info options}] -#puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!" - set opt_lst [list configure] - foreach opt [lsort $myOptions] { - set found 0 - if {[catch { - set resource [uplevel 1 info option $opt -resource] - set class [uplevel 1 info option $opt -class] - set default_val [uplevel 1 info option $opt -default] - set found 1 - } msg]} { -# puts stderr "MSG!$opt!$msg!" - } -#puts stderr "OPT!$opt!$found!" - if {$found} { - set val "" - if {[::dict exists $argsDict $opt]} { - # we have an explicitly set option - set val [::dict get $argsDict $opt] - } else { - if {[string length $val] == 0} { - set val $default_val - } - } - set myObj [uplevel 1 set this] -#puts stderr "myObj!$myObj!" - set ::itcl::internal::variables::${myObj}::itcl_options($opt) $val - set ::itcl::internal::variables::${myObj}::__itcl_option_infos($opt) [list $resource $class $default_val] -#puts stderr "OPT1!$opt!$val!" - uplevel 1 [list set itcl_options($opt) [list $val]] -# if {[catch {uplevel 1 $myObj configure $opt [list $val]} msg]} { -#puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!" -# } - } - } -# uplevel 1 $opt_lst -} - -# ========================= keepcomponentoption ====================== -# Invoked by Tcl during evaluating constructor whenever -# the "keepcomponentoption" command is invoked to list the options -# to be kept when an ::itcl::extendedclass component has been setup -# for an object. -# -# It checks, for all arguments, if the opt is an option of that class -# and of that component. If that is the case it adds the component name -# to the list of components for that option. -# The variable is the object variable: itcl_option_components($opt) -# -# Handles the following syntax: -# -# keepcomponentoption <componentName> <optionName> ?<optionName> ...? -# -# ====================================================================== - - -proc keepcomponentoption {args} { - upvar win win - upvar itcl_hull itcl_hull - - set usage "wrong # args, should be: keepcomponentoption componentName optionName ?optionName ...?" - -#puts stderr "KEEP!$args![uplevel 1 namespace current]!" - if {[llength $args] < 2} { - puts stderr $usage - return -code error - } - set my_hull [uplevel 1 set itcl_hull] - set my_class [uplevel 1 namespace current] - set comp [lindex $args 0] - set args [lrange $args 1 end] - set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class] - if {![dict exists $class_info_dict $comp]} { - puts stderr "keepcomponentoption cannot find component \"$comp\"" - return -code error - } - set class_comp_dict [dict get $class_info_dict $comp] - if {![dict exists $class_comp_dict -keptoptions]} { - dict set class_comp_dict -keptoptions [list] - } - foreach opt $args { -#puts stderr "KEEP!$opt!" - if {[string range $opt 0 0] ne "-"} { - puts stderr "keepcomponentoption: option must begin with a \"-\"!" - return -code error - } - if {[lsearch [dict get $class_comp_dict -keptoptions] $opt] < 0} { - dict lappend class_comp_dict -keptoptions $opt - } - } - if {![info exists ::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])]} { - set comp_object $::itcl::internal::component_objects([lindex [uplevel 1 info context] 1]) - } else { - set comp_object "unknown_comp_obj_$comp!" - } - dict set class_info_dict $comp $class_comp_dict - dict set ::itcl::internal::dicts::classComponents $my_class $class_info_dict -puts stderr "CLDI!$class_comp_dict!" - addToItclOptions $my_class $comp_object $args [list] -} - -proc ignorecomponentoption {args} { -puts stderr "IGNORE_COMPONENT_OPTION!$args!" -} - -proc renamecomponentoption {args} { -puts stderr "rename_COMPONENT_OPTION!$args!" -} - -proc addoptioncomponent {args} { -puts stderr "ADD_OPTION_COMPONENT!$args!" -} - -proc ignoreoptioncomponent {args} { -puts stderr "IGNORE_OPTION_COMPONENT!$args!" -} - -proc renameoptioncomponent {args} { -puts stderr "RENAME_OPTION_COMPONENT!$args!" -} - -proc getEclassOptions {args} { - upvar win win - -#puts stderr "getEclassOptions!$args!$win![uplevel 1 namespace current]!" -#parray ::itcl::internal::variables::${win}::itcl_options - set result [list] - foreach opt [array names ::itcl::internal::variables::${win}::itcl_options] { - if {[catch { - foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break - lappend result [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]] - } msg]} { - } - } - return $result -} - -proc eclassConfigure {args} { - upvar win win - -#puts stderr "+++ eclassConfigure!$args!" - if {[llength $args] > 1} { - foreach {opt val} $args break - if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} { - set ::itcl::internal::variables::${win}::itcl_options($opt) $val - return - } - } else { - foreach {opt} $args break - if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} { -#puts stderr "OP![set ::itcl::internal::variables::${win}::itcl_options($opt)]!" - foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break - return [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]] - } - } - return -code error -} - -} diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itclWidget.tcl b/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itclWidget.tcl deleted file mode 100644 index 5fcda510e0..0000000000 --- a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itclWidget.tcl +++ /dev/null @@ -1,447 +0,0 @@ -# -# itclWidget.tcl -# ---------------------------------------------------------------------- -# Invoked automatically upon startup to customize the interpreter -# for [incr Tcl] when one of ::itcl::widget or ::itcl::widgetadaptor is called. -# ---------------------------------------------------------------------- -# AUTHOR: Arnulf P. Wiedemann -# -# ---------------------------------------------------------------------- -# Copyright (c) 2008 Arnulf P. Wiedemann -# ====================================================================== -# See the file "license.terms" for information on usage and -# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -package require Tk 8.6 -# package require itclwidget [set ::itcl::version] - -namespace eval ::itcl { - -proc widget {name args} { - set result [uplevel 1 ::itcl::internal::commands::genericclass widget $name $args] - # we handle create by owerselfs !! allow classunknown to handle that - oo::objdefine $result unexport create - return $result -} - -proc widgetadaptor {name args} { - set result [uplevel 1 ::itcl::internal::commands::genericclass widgetadaptor $name $args] - # we handle create by owerselfs !! allow classunknown to handle that - oo::objdefine $result unexport create - return $result -} - -} ; # end ::itcl - - -namespace eval ::itcl::internal::commands { - -proc initWidgetOptions {varNsName widgetName className} { - set myDict [set ::itcl::internal::dicts::classOptions] - if {$myDict eq ""} { - return - } - if {![dict exists $myDict $className]} { - return - } - set myDict [dict get $myDict $className] - foreach option [dict keys $myDict] { - set infos [dict get $myDict $option] - set resource [dict get $infos -resource] - set class [dict get $infos -class] - set value [::option get $widgetName $resource $class] - if {$value eq ""} { - if {[dict exists $infos -default]} { - set defaultValue [dict get $infos -default] - uplevel 1 set ${varNsName}::itcl_options($option) $defaultValue - } - } else { - uplevel 1 set ${varNsName}::itcl_options($option) $value - } - } -} - -proc initWidgetDelegatedOptions {varNsName widgetName className args} { - set myDict [set ::itcl::internal::dicts::classDelegatedOptions] - if {$myDict eq ""} { - return - } - if {![dict exists $myDict $className]} { - return - } - set myDict [dict get $myDict $className] - foreach option [dict keys $myDict] { - set infos [dict get $myDict $option] - if {![dict exists $infos -resource]} { - # this is the case when delegating "*" - continue - } - if {![dict exists $infos -component]} { - # nothing to do - continue - } - # check if not in the command line options - # these have higher priority - set myOption $option - if {[dict exists $infos -as]} { - set myOption [dict get $infos -as] - } - set noOptionSet 0 - foreach {optName optVal} $args { - if {$optName eq $myOption} { - set noOptionSet 1 - break - } - } - if {$noOptionSet} { - continue - } - set resource [dict get $infos -resource] - set class [dict get $infos -class] - set component [dict get $infos -component] - set value [::option get $widgetName $resource $class] - if {$component ne ""} { - if {$value ne ""} { - set compVar [namespace eval ${varNsName}${className} "set $component"] - if {$compVar ne ""} { - uplevel 1 $compVar configure $myOption $value - } - } - } - } -} - -proc widgetinitobjectoptions {varNsName widgetName className} { -#puts stderr "initWidgetObjectOptions!$varNsName!$widgetName!$className!" -} - -proc deletehull {newName oldName what} { - if {$what eq "delete"} { - set name [namespace tail $newName] - regsub {hull[0-9]+} $name {} name - rename $name {} - } - if {$what eq "rename"} { - set name [namespace tail $newName] - regsub {hull[0-9]+} $name {} name - rename $name {} - } -} - -proc hullandoptionsinstall {objectName className widgetClass hulltype args} { - if {$hulltype eq ""} { - set hulltype frame - } - set idx 0 - set found 0 - foreach {optName optValue} $args { - if {$optName eq "-class"} { - set found 1 - set widgetClass $optValue - break - } - incr idx - } - if {$found} { - set args [lreplace $args $idx [expr {$idx + 1}]] - } - if {$widgetClass eq ""} { - set widgetClass $className - set widgetClass [string totitle $widgetClass] - } - set cmd "set win $objectName; ::itcl::builtin::installhull using $hulltype -class $widgetClass $args" - uplevel 2 $cmd -} - -} ; # end ::itcl::internal::commands - -namespace eval ::itcl::builtin { - -proc installhull {args} { - set cmdPath ::itcl::internal::commands - set className [uplevel 1 info class] - - set replace 0 - switch -- [llength $args] { - 0 { - return -code error\ - "wrong # args: should be \"[lindex [info level 0] 0]\ - name|using <widgetType> ?arg ...?\"" - } - 1 { - set widgetName [lindex $args 0] - set varNsName $::itcl::internal::varNsName($widgetName) - } - default { - upvar win win - set widgetName $win - - set varNsName $::itcl::internal::varNsName($widgetName) - set widgetType [lindex $args 1] - incr replace - if {[llength $args] > 3 && [lindex $args 2] eq "-class"} { - set classNam [lindex $args 3] - incr replace 2 - } else { - set classNam [string totitle $widgetType] - } - uplevel 1 [lreplace $args 0 $replace $widgetType $widgetName -class $classNam] - uplevel 1 [list ${cmdPath}::initWidgetOptions $varNsName $widgetName $className] - } - } - - # initialize the itcl_hull variable - set i 0 - set nam ::itcl::internal::widgets::hull - while {1} { - incr i - set hullNam ${nam}${i}$widgetName - if {[::info command $hullNam] eq ""} { - break - } - } - uplevel 1 [list ${cmdPath}::sethullwindowname $widgetName] - uplevel 1 [list ::rename $widgetName $hullNam] - uplevel 1 [list ::trace add command $hullNam {delete rename} ::itcl::internal::commands::deletehull] - catch {${cmdPath}::checksetitclhull [list] 0} - namespace eval ${varNsName}${className} "set itcl_hull $hullNam" - catch {${cmdPath}::checksetitclhull [list] 2} - uplevel 1 [lreplace $args 0 $replace ${cmdPath}::initWidgetDelegatedOptions $varNsName $widgetName $className] -} - -proc installcomponent {args} { - upvar win win - - set className [uplevel 1 info class] - set myType [${className}::info types [namespace tail $className]] - set isType 0 - if {$myType ne ""} { - set isType 1 - } - set numArgs [llength $args] - set usage "usage: installcomponent <componentName> using <widgetType> <widgetPath> ?-option value ...?" - if {$numArgs < 4} { - error $usage - } - foreach {componentName using widgetType widgetPath} $args break - set opts [lrange $args 4 end] - if {$using ne "using"} { - error $usage - } - if {!$isType} { - set hullExists [uplevel 1 ::info exists itcl_hull] - if {!$hullExists} { - error "cannot install \"$componentName\" before \"itcl_hull\" exists" - } - set hullVal [uplevel 1 set itcl_hull] - if {$hullVal eq ""} { - error "cannot install \"$componentName\" before \"itcl_hull\" exists" - } - } - # check for delegated option and ask the option database for the values - # first check for number of delegated options - set numOpts 0 - set starOption 0 - set myDict [set ::itcl::internal::dicts::classDelegatedOptions] - if {[dict exists $myDict $className]} { - set myDict [dict get $myDict $className] - foreach option [dict keys $myDict] { - if {$option eq "*"} { - set starOption 1 - } - incr numOpts - } - } - set myOptionDict [set ::itcl::internal::dicts::classOptions] - if {[dict exists $myOptionDict $className]} { - set myOptionDict [dict get $myOptionDict $className] - } - set cmd [list $widgetPath configure] - set cmd1 "set $componentName \[$widgetType $widgetPath\]" - uplevel 1 $cmd1 - if {$starOption} { - upvar $componentName compName - set cmd1 [list $compName configure] - set configInfos [uplevel 1 $cmd1] - foreach entry $configInfos { - if {[llength $entry] > 2} { - foreach {optName resource class defaultValue} $entry break - set val "" - catch { - set val [::option get $win $resource $class] - } - if {$val ne ""} { - set addOpt 1 - if {[dict exists $myDict $$optName]} { - set addOpt 0 - } else { - set starDict [dict get $myDict "*"] - if {[dict exists $starDict -except]} { - set exceptions [dict get $starDict -except] - if {[lsearch $exceptions $optName] >= 0} { - set addOpt 0 - } - - } - if {[dict exists $myOptionDict $optName]} { - set addOpt 0 - } - } - if {$addOpt} { - lappend cmd $optName $val - } - - } - - } - } - } else { - foreach optName [dict keys $myDict] { - set optInfos [dict get $myDict $optName] - set resource [dict get $optInfos -resource] - set class [namespace tail $className] - set class [string totitle $class] - set val "" - catch { - set val [::option get $win $resource $class] - } - if {$val ne ""} { - if {[dict exists $optInfos -as] } { - set optName [dict get $optInfos -as] - } - lappend cmd $optName $val - } - } - } - lappend cmd {*}$opts - uplevel 1 $cmd -} - -} ; # end ::itcl::builtin - -set ::itcl::internal::dicts::hullTypes [list \ - frame \ - toplevel \ - labelframe \ - ttk:frame \ - ttk:toplevel \ - ttk:labelframe \ - ] - -namespace eval ::itcl::builtin::Info { - -proc hulltypes {args} { - namespace upvar ::itcl::internal::dicts hullTypes hullTypes - - set numArgs [llength $args] - if {$numArgs > 1} { - error "wrong # args should be: info hulltypes ?<pattern>?" - } - set pattern "" - if {$numArgs > 0} { - set pattern [lindex $args 0] - } - if {$pattern ne ""} { - return [lsearch -all -inline -glob $hullTypes $pattern] - } - return $hullTypes - -} - -proc widgetclasses {args} { - set numArgs [llength $args] - if {$numArgs > 1} { - error "wrong # args should be: info widgetclasses ?<pattern>?" - } - set pattern "" - if {$numArgs > 0} { - set pattern [lindex $args 0] - } - set myDict [set ::itcl::internal::dicts::classes] - if {![dict exists $myDict widget]} { - return [list] - } - set myDict [dict get $myDict widget] - set result [list] - if {$pattern ne ""} { - foreach key [dict keys $myDict] { - set myInfo [dict get $myDict $key] - set value [dict get $myInfo -widget] - if {[string match $pattern $value]} { - lappend result $value - } - } - } else { - foreach key [dict keys $myDict] { - set myInfo [dict get $myDict $key] - lappend result [dict get $myInfo -widget] - } - } - return $result -} - -proc widgets {args} { - set numArgs [llength $args] - if {$numArgs > 1} { - error "wrong # args should be: info widgets ?<pattern>?" - } - set pattern "" - if {$numArgs > 0} { - set pattern [lindex $args 0] - } - set myDict [set ::itcl::internal::dicts::classes] - if {![dict exists $myDict widget]} { - return [list] - } - set myDict [dict get $myDict widget] - set result [list] - if {$pattern ne ""} { - foreach key [dict keys $myDict] { - set myInfo [dict get $myDict $key] - set value [dict get $myInfo -name] - if {[string match $pattern $value]} { - lappend result $value - } - } - } else { - foreach key [dict keys $myDict] { - set myInfo [dict get $myDict $key] - lappend result [dict get $myInfo -name] - } - } - return $result -} - -proc widgetadaptors {args} { - set numArgs [llength $args] - if {$numArgs > 1} { - error "wrong # args should be: info widgetadaptors ?<pattern>?" - } - set pattern "" - if {$numArgs > 0} { - set pattern [lindex $args 0] - } - set myDict [set ::itcl::internal::dicts::classes] - if {![dict exists $myDict widgetadaptor]} { - return [list] - } - set myDict [dict get $myDict widgetadaptor] - set result [list] - if {$pattern ne ""} { - foreach key [dict keys $myDict] { - set myInfo [dict get $myDict $key] - set value [dict get $myInfo -name] - if {[string match $pattern $value]} { - lappend result $value - } - } - } else { - foreach key [dict keys $myDict] { - set myInfo [dict get $myDict $key] - lappend result [dict get $myInfo -name] - } - } - return $result -} - -} ; # end ::itcl::builtin::Info diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/pkgIndex.tcl b/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/pkgIndex.tcl deleted file mode 100644 index d18d2cc519..0000000000 --- a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/pkgIndex.tcl +++ /dev/null @@ -1,14 +0,0 @@ -# -*- tcl -*- -# Tcl package index file, version 1.1 -# - -if {![package vsatisfies [package provide Tcl] 8.6-]} {return} - -if {[package vsatisfies [package provide Tcl] 9.0-]} { - package ifneeded itcl 4.2.2 \ - [list load [file join $dir tcl9itcl422.dll] Itcl] -} else { - package ifneeded itcl 4.2.2 \ - [list load [file join $dir itcl422.dll] Itcl] -} -package ifneeded Itcl 4.2.2 [list package require -exact itcl 4.2.2] |