# # 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 _ # 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 # and widget is renamed to that name # Finally the _ is renamed to the original again # Component itcl_hull is created if not existent # itcl_hull is set to the hull_widget_name and the # 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 ? ...? # # ====================================================================== 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 } }