diff options
Diffstat (limited to 'Master/tlpkg/tltcl/lib/itcl4.2.3')
-rw-r--r-- | Master/tlpkg/tltcl/lib/itcl4.2.3/itcl.tcl | 151 | ||||
-rw-r--r-- | Master/tlpkg/tltcl/lib/itcl4.2.3/itcl423.dll | bin | 0 -> 367016 bytes | |||
-rw-r--r-- | Master/tlpkg/tltcl/lib/itcl4.2.3/itclConfig.sh | 67 | ||||
-rw-r--r-- | Master/tlpkg/tltcl/lib/itcl4.2.3/itclHullCmds.tcl | 562 | ||||
-rw-r--r-- | Master/tlpkg/tltcl/lib/itcl4.2.3/itclWidget.tcl | 447 | ||||
-rw-r--r-- | Master/tlpkg/tltcl/lib/itcl4.2.3/libitclstub423.a | bin | 0 -> 1778 bytes | |||
-rw-r--r-- | Master/tlpkg/tltcl/lib/itcl4.2.3/pkgIndex.tcl | 14 |
7 files changed, 1241 insertions, 0 deletions
diff --git a/Master/tlpkg/tltcl/lib/itcl4.2.3/itcl.tcl b/Master/tlpkg/tltcl/lib/itcl4.2.3/itcl.tcl new file mode 100644 index 00000000000..15ca2200f4d --- /dev/null +++ b/Master/tlpkg/tltcl/lib/itcl4.2.3/itcl.tcl @@ -0,0 +1,151 @@ +# +# 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/Master/tlpkg/tltcl/lib/itcl4.2.3/itcl423.dll b/Master/tlpkg/tltcl/lib/itcl4.2.3/itcl423.dll Binary files differnew file mode 100644 index 00000000000..b5f698f7b17 --- /dev/null +++ b/Master/tlpkg/tltcl/lib/itcl4.2.3/itcl423.dll diff --git a/Master/tlpkg/tltcl/lib/itcl4.2.3/itclConfig.sh b/Master/tlpkg/tltcl/lib/itcl4.2.3/itclConfig.sh new file mode 100644 index 00000000000..94c22b7c667 --- /dev/null +++ b/Master/tlpkg/tltcl/lib/itcl4.2.3/itclConfig.sh @@ -0,0 +1,67 @@ +# 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.3' +ITCL_VERSION='4.2.3' + +# The name of the Itcl library (may be either a .a file or a shared library): +itcl_LIB_FILE=itcl423.dll +ITCL_LIB_FILE=itcl423.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.13/win/pkgs/itcl4.2.3 -litcl423' +ITCL_BUILD_LIB_SPEC='-L/tmp/siepo/tcl8.6.13/win/pkgs/itcl4.2.3 -litcl423' + +# 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.3 -litcl423' +ITCL_LIB_SPEC='-L/home/siepo/tltcl/lib/itcl4.2.3 -litcl423' + +# The name of the Itcl stub library (a .a file): +itcl_STUB_LIB_FILE=libitclstub423.a +ITCL_STUB_LIB_FILE=libitclstub423.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.13/win/pkgs/itcl4.2.3 -litclstub423' +ITCL_BUILD_STUB_LIB_SPEC='-L/tmp/siepo/tcl8.6.13/win/pkgs/itcl4.2.3 -litclstub423' + +# 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.3 -litclstub423' +ITCL_STUB_LIB_SPEC='-L/home/siepo/tltcl/lib/itcl4.2.3 -litclstub423' + +# 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.13/win/pkgs/itcl4.2.3/libitclstub423.a' +ITCL_BUILD_STUB_LIB_PATH='/tmp/siepo/tcl8.6.13/win/pkgs/itcl4.2.3/libitclstub423.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.3/libitclstub423.a' +ITCL_STUB_LIB_PATH='/home/siepo/tltcl/lib/itcl4.2.3/libitclstub423.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.13/pkgs/itcl4.2.3' +ITCL_SRC_DIR='/tmp/siepo/tcl8.6.13/pkgs/itcl4.2.3' + +# String to pass to the compiler so that an extension can +# find installed Itcl headers. +itcl_INCLUDE_SPEC='-I/tmp/siepo/tcl8.6.13/pkgs/itcl4.2.3/generic' +ITCL_INCLUDE_SPEC='-I/tmp/siepo/tcl8.6.13/pkgs/itcl4.2.3/generic' diff --git a/Master/tlpkg/tltcl/lib/itcl4.2.3/itclHullCmds.tcl b/Master/tlpkg/tltcl/lib/itcl4.2.3/itclHullCmds.tcl new file mode 100644 index 00000000000..282041187c6 --- /dev/null +++ b/Master/tlpkg/tltcl/lib/itcl4.2.3/itclHullCmds.tcl @@ -0,0 +1,562 @@ +# +# 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/Master/tlpkg/tltcl/lib/itcl4.2.3/itclWidget.tcl b/Master/tlpkg/tltcl/lib/itcl4.2.3/itclWidget.tcl new file mode 100644 index 00000000000..5fcda510e09 --- /dev/null +++ b/Master/tlpkg/tltcl/lib/itcl4.2.3/itclWidget.tcl @@ -0,0 +1,447 @@ +# +# 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/Master/tlpkg/tltcl/lib/itcl4.2.3/libitclstub423.a b/Master/tlpkg/tltcl/lib/itcl4.2.3/libitclstub423.a Binary files differnew file mode 100644 index 00000000000..d04a03d1bf8 --- /dev/null +++ b/Master/tlpkg/tltcl/lib/itcl4.2.3/libitclstub423.a diff --git a/Master/tlpkg/tltcl/lib/itcl4.2.3/pkgIndex.tcl b/Master/tlpkg/tltcl/lib/itcl4.2.3/pkgIndex.tcl new file mode 100644 index 00000000000..e06645f55b1 --- /dev/null +++ b/Master/tlpkg/tltcl/lib/itcl4.2.3/pkgIndex.tcl @@ -0,0 +1,14 @@ +# -*- 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.3 \ + [list load [file join $dir tcl9itcl423.dll] Itcl] +} else { + package ifneeded itcl 4.2.3 \ + [list load [file join $dir itcl423.dll] Itcl] +} +package ifneeded Itcl 4.2.3 [list package require -exact itcl 4.2.3] |