summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1
diff options
context:
space:
mode:
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1')
-rw-r--r--systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/itcl.tcl151
-rwxr-xr-xsystems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/itcl421.dllbin336910 -> 0 bytes
-rw-r--r--systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/itclConfig.sh67
-rw-r--r--systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/itclHullCmds.tcl562
-rw-r--r--systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/itclWidget.tcl447
-rw-r--r--systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/libitclstub421.abin1516 -> 0 bytes
-rw-r--r--systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/pkgIndex.tcl21
7 files changed, 0 insertions, 1248 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/itcl.tcl b/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/itcl.tcl
deleted file mode 100644
index 15ca2200f4..0000000000
--- a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/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.1/itcl421.dll b/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/itcl421.dll
deleted file mode 100755
index 619006997a..0000000000
--- a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/itcl421.dll
+++ /dev/null
Binary files differ
diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/itclConfig.sh b/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/itclConfig.sh
deleted file mode 100644
index 1616bf3702..0000000000
--- a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/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.1'
-ITCL_VERSION='4.2.1'
-
-# The name of the Itcl library (may be either a .a file or a shared library):
-itcl_LIB_FILE=itcl421.dll
-ITCL_LIB_FILE=itcl421.dll
-
-# String to pass to linker to pick up the Itcl library from its
-# build directory.
-itcl_BUILD_LIB_SPEC='-L/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/itcl4.2.1 -litcl421'
-ITCL_BUILD_LIB_SPEC='-L/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/itcl4.2.1 -litcl421'
-
-# String to pass to linker to pick up the Itcl library from its
-# installed directory.
-itcl_LIB_SPEC='-L/home/siepo/tltcl/lib/itcl4.2.1 -litcl421'
-ITCL_LIB_SPEC='-L/home/siepo/tltcl/lib/itcl4.2.1 -litcl421'
-
-# The name of the Itcl stub library (a .a file):
-itcl_STUB_LIB_FILE=libitclstub421.a
-ITCL_STUB_LIB_FILE=libitclstub421.a
-
-# String to pass to linker to pick up the Itcl stub library from its
-# build directory.
-itcl_BUILD_STUB_LIB_SPEC='-L/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/itcl4.2.1 -litclstub421'
-ITCL_BUILD_STUB_LIB_SPEC='-L/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/itcl4.2.1 -litclstub421'
-
-# String to pass to linker to pick up the Itcl stub library from its
-# installed directory.
-itcl_STUB_LIB_SPEC='-L/home/siepo/tltcl/lib/itcl4.2.1 -litclstub421'
-ITCL_STUB_LIB_SPEC='-L/home/siepo/tltcl/lib/itcl4.2.1 -litclstub421'
-
-# String to pass to linker to pick up the Itcl stub library from its
-# build directory.
-itcl_BUILD_STUB_LIB_PATH='/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/itcl4.2.1/libitclstub421.a'
-ITCL_BUILD_STUB_LIB_PATH='/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/itcl4.2.1/libitclstub421.a'
-
-# String to pass to linker to pick up the Itcl stub library from its
-# installed directory.
-itcl_STUB_LIB_PATH='/home/siepo/tltcl/lib/itcl4.2.1/libitclstub421.a'
-ITCL_STUB_LIB_PATH='/home/siepo/tltcl/lib/itcl4.2.1/libitclstub421.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='/home/siepo/xdrive/tltcl/tcl8.6.11/pkgs/itcl4.2.1'
-ITCL_SRC_DIR='/home/siepo/xdrive/tltcl/tcl8.6.11/pkgs/itcl4.2.1'
-
-# String to pass to the compiler so that an extension can
-# find installed Itcl headers.
-itcl_INCLUDE_SPEC='-I/home/siepo/xdrive/tltcl/tcl8.6.11/pkgs/itcl4.2.1/generic'
-ITCL_INCLUDE_SPEC='-I/home/siepo/xdrive/tltcl/tcl8.6.11/pkgs/itcl4.2.1/generic'
diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/itclHullCmds.tcl b/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/itclHullCmds.tcl
deleted file mode 100644
index 282041187c..0000000000
--- a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/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.1/itclWidget.tcl b/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/itclWidget.tcl
deleted file mode 100644
index 5fcda510e0..0000000000
--- a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/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.1/libitclstub421.a b/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/libitclstub421.a
deleted file mode 100644
index c070af8e7e..0000000000
--- a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/libitclstub421.a
+++ /dev/null
Binary files differ
diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/pkgIndex.tcl b/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/pkgIndex.tcl
deleted file mode 100644
index 4526cae8a1..0000000000
--- a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/pkgIndex.tcl
+++ /dev/null
@@ -1,21 +0,0 @@
-# Tcl package index file, version 1.0
-#
-# Do NOT try this command
-#
-# if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
-#
-# as a way to accept working with all of Tcl 8.6, Tcl 8.X, X>6, and
-# Tcl Y, for Y > 8.
-# Itcl is a binary package, added to an interp with [load].
-# There is no libitcl.so that will [load] into both Tcl 8 and Tcl 9.
-# The indexed libitcl.so was built to [load] into one or the other.
-# Thus the pkgIndex.tcl should only accept the version of Tcl for which
-# the indexed itcl421.dll was built.
-#
-# More work replacing the literal "8.6" below with the proper value substituted
-# by configure is the right way forward.
-
-if {![package vsatisfies [package provide Tcl] 8.6]} {return}
-
-package ifneeded itcl 4.2.1 [list load [file join $dir "itcl421.dll"] Itcl]
-package ifneeded Itcl 4.2.1 [list load [file join $dir "itcl421.dll"] Itcl]