summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tltcl/lib/itcl4.2.1/itclHullCmds.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tltcl/lib/itcl4.2.1/itclHullCmds.tcl')
-rw-r--r--Master/tlpkg/tltcl/lib/itcl4.2.1/itclHullCmds.tcl562
1 files changed, 562 insertions, 0 deletions
diff --git a/Master/tlpkg/tltcl/lib/itcl4.2.1/itclHullCmds.tcl b/Master/tlpkg/tltcl/lib/itcl4.2.1/itclHullCmds.tcl
new file mode 100644
index 00000000000..282041187c6
--- /dev/null
+++ b/Master/tlpkg/tltcl/lib/itcl4.2.1/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
+}
+
+}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-06 17:17:01 +0000