diff options
Diffstat (limited to 'Master/tlpkg/tltcl/lib/itcl4.2.2/itclHullCmds.tcl')
-rw-r--r-- | Master/tlpkg/tltcl/lib/itcl4.2.2/itclHullCmds.tcl | 562 |
1 files changed, 562 insertions, 0 deletions
diff --git a/Master/tlpkg/tltcl/lib/itcl4.2.2/itclHullCmds.tcl b/Master/tlpkg/tltcl/lib/itcl4.2.2/itclHullCmds.tcl new file mode 100644 index 00000000000..282041187c6 --- /dev/null +++ b/Master/tlpkg/tltcl/lib/itcl4.2.2/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 +} + +} |