jpayne@69: #
jpayne@69: # itclHullCmds.tcl
jpayne@69: # ----------------------------------------------------------------------
jpayne@69: # Invoked automatically upon startup to customize the interpreter
jpayne@69: # for [incr Tcl] when one of setupcomponent or createhull is called.
jpayne@69: # ----------------------------------------------------------------------
jpayne@69: #   AUTHOR:  Arnulf P. Wiedemann
jpayne@69: #
jpayne@69: # ----------------------------------------------------------------------
jpayne@69: #            Copyright (c) 2008  Arnulf P. Wiedemann
jpayne@69: # ======================================================================
jpayne@69: # See the file "license.terms" for information on usage and
jpayne@69: # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
jpayne@69: 
jpayne@69: package require Tk 8.6
jpayne@69: 
jpayne@69: namespace eval ::itcl::internal::commands {
jpayne@69: 
jpayne@69: # ======================= widgetDeleted ===========================
jpayne@69: 
jpayne@69: proc widgetDeleted {oldName newName op} {
jpayne@69:     # The widget is beeing deleted, so we have to delete the object
jpayne@69:     # which had the widget as itcl_hull too!
jpayne@69:     # We have to get the real name from for example
jpayne@69:     # ::itcl::internal::widgets::hull1.lw
jpayne@69:     # we need only .lw here
jpayne@69: 
jpayne@69: #puts stderr "widgetDeleted!$oldName!$newName!$op!"
jpayne@69:     set cmdName [namespace tail $oldName]
jpayne@69:     set flds [split $cmdName {.}]
jpayne@69:     set cmdName .[join [lrange $flds 1 end] {.}]
jpayne@69: #puts stderr "DELWIDGET![namespace current]!$cmdName![::info command $cmdName]!"
jpayne@69:     rename $cmdName {}
jpayne@69: }
jpayne@69: 
jpayne@69: }
jpayne@69: 
jpayne@69: namespace eval ::itcl::builtin {
jpayne@69: 
jpayne@69: # ======================= createhull ===========================
jpayne@69: # the hull widget is a tk widget which is the (mega) widget handled behind the itcl
jpayne@69: # extendedclass/itcl widget.
jpayne@69: # It is created be renaming the itcl class object to a temporary name <itcl object name>_
jpayne@69: # creating the widget with the
jpayne@69: # appropriate options and the installing that as the "hull" widget (the container)
jpayne@69: # All the options in args and the options delegated to component itcl_hull are used
jpayne@69: # Then a unique name (hull_widget_name) in the itcl namespace is created for widget:
jpayne@69: # ::itcl::internal::widgets::hull<unique number><namespace tail path>
jpayne@69: # and widget is renamed to that name
jpayne@69: # Finally the <itcl object name>_ is renamed to the original <itcl object name> again
jpayne@69: # Component itcl_hull is created if not existent
jpayne@69: # itcl_hull is set to the hull_widget_name and the <itcl object name>
jpayne@69: # is returned to the caller
jpayne@69: # ==============================================================
jpayne@69: 
jpayne@69: proc createhull {widget_type path args} {
jpayne@69:     variable hullCount
jpayne@69:     upvar this this
jpayne@69:     upvar win win
jpayne@69: 
jpayne@69: 
jpayne@69: #puts stderr "il-1![::info level -1]!$this!"
jpayne@69: #puts stderr "createhull!$widget_type!$path!$args!$this![::info command $this]!"
jpayne@69: #puts stderr "ns1![uplevel 1 namespace current]!"
jpayne@69: #puts stderr "ns2![uplevel 2 namespace current]!"
jpayne@69: #puts stderr "ns3![uplevel 3 namespace current]!"
jpayne@69: #puts stderr "level-1![::info level -1]!"
jpayne@69: #puts stderr "level-2![::info level -2]!"
jpayne@69: #    set my_this [namespace tail $this]
jpayne@69:     set my_this $this
jpayne@69:     set tmp $my_this
jpayne@69: #puts stderr "II![::info command $this]![::info command $tmp]!"
jpayne@69: #puts stderr "rename1!rename $my_this ${tmp}_!"
jpayne@69:     rename ::$my_this ${tmp}_
jpayne@69:     set options [list]
jpayne@69:     foreach {option_name value} $args {
jpayne@69:         switch -glob -- $option_name {
jpayne@69: 	-class {
jpayne@69: 	      lappend options $option_name [namespace tail $value]
jpayne@69: 	  }
jpayne@69:         -* {
jpayne@69:             lappend options $option_name $value
jpayne@69:           }
jpayne@69:         default {
jpayne@69: 	    return -code error "bad option name\"$option_name\" options must start with a \"-\""
jpayne@69:           }
jpayne@69:         }
jpayne@69:     }
jpayne@69:     set my_win [namespace tail $path]
jpayne@69:     set cmd [list $widget_type $my_win]
jpayne@69: #puts stderr "my_win!$my_win!cmd!$cmd!$path!"
jpayne@69:     if {[llength $options] > 0} {
jpayne@69:         lappend cmd {*}$options
jpayne@69:     }
jpayne@69:     set widget [uplevel 1 $cmd]
jpayne@69: #puts stderr "widget!$widget!"
jpayne@69:     trace add command $widget delete ::itcl::internal::commands::widgetDeleted
jpayne@69:     set opts [uplevel 1 info delegated options]
jpayne@69:     foreach entry $opts {
jpayne@69:         foreach {optName compName} $entry break
jpayne@69: 	if {$compName eq "itcl_hull"} {
jpayne@69: 	    set optInfos [uplevel 1 info delegated option $optName]
jpayne@69: 	    set realOptName [lindex $optInfos 4]
jpayne@69: 	    # strip off the "-" at the beginning
jpayne@69: 	    set myOptName [string range $realOptName 1 end]
jpayne@69:             set my_opt_val [option get $my_win $myOptName *]
jpayne@69:             if {$my_opt_val ne ""} {
jpayne@69:                 $my_win configure -$myOptName $my_opt_val
jpayne@69:             }
jpayne@69: 	}
jpayne@69:     }
jpayne@69:     set idx 1
jpayne@69:     while {1} {
jpayne@69:         set widgetName ::itcl::internal::widgets::hull${idx}$my_win
jpayne@69: #puts stderr "widgetName!$widgetName!"
jpayne@69: 	if {[string length [::info command $widgetName]] == 0} {
jpayne@69: 	    break
jpayne@69: 	}
jpayne@69:         incr idx
jpayne@69:     }
jpayne@69: #puts stderr "rename2!rename $widget $widgetName!"
jpayne@69:     set dorename 0
jpayne@69:     rename $widget $widgetName
jpayne@69: #puts stderr "rename3!rename ${tmp}_ $tmp![::info command ${tmp}_]!my_this!$my_this!"
jpayne@69:     rename ${tmp}_ ::$tmp
jpayne@69:     set exists [uplevel 1 ::info exists itcl_hull]
jpayne@69:     if {!$exists} {
jpayne@69: 	# that does not yet work, beacause of problems with resolving
jpayne@69:         ::itcl::addcomponent $my_this itcl_hull
jpayne@69:     }
jpayne@69:     upvar itcl_hull itcl_hull
jpayne@69:     ::itcl::setcomponent $my_this itcl_hull $widgetName
jpayne@69: #puts stderr "IC![::info command $my_win]!"
jpayne@69:     set exists [uplevel 1 ::info exists itcl_interior]
jpayne@69:     if {!$exists} {
jpayne@69: 	# that does not yet work, beacause of problems with resolving
jpayne@69:         ::itcl::addcomponent $this itcl_interior
jpayne@69:     }
jpayne@69:     upvar itcl_interior itcl_interior
jpayne@69:     set itcl_interior $my_win
jpayne@69: #puts stderr "hull end!win!$win!itcl_hull!$itcl_hull!itcl_interior!$itcl_interior!"
jpayne@69:     return $my_win
jpayne@69: }
jpayne@69: 
jpayne@69: # ======================= addToItclOptions ===========================
jpayne@69: 
jpayne@69: proc addToItclOptions {my_class my_win myOptions argsDict} {
jpayne@69:     upvar win win
jpayne@69:     upvar itcl_hull itcl_hull
jpayne@69: 
jpayne@69:     set opt_lst [list configure]
jpayne@69:     foreach opt [lsort $myOptions] {
jpayne@69: #puts stderr "IOPT!$opt!$my_class!$my_win![::itcl::is class $my_class]!"
jpayne@69:         set isClass [::itcl::is class $my_class]
jpayne@69: 	set found 0
jpayne@69: 	if {$isClass} {
jpayne@69:             if {[catch {
jpayne@69:                 set resource [namespace eval $my_class info option $opt -resource]
jpayne@69:                 set class [namespace eval $my_class info option $opt -class]
jpayne@69:                 set default_val [uplevel 2 info option $opt -default]
jpayne@69:                 set found 1
jpayne@69:             } msg]} {
jpayne@69: #                puts stderr "MSG!$opt!$my_class!$msg!"
jpayne@69:             }
jpayne@69:         } else {
jpayne@69:             set tmp_win [uplevel #0 $my_class .___xx]
jpayne@69: 
jpayne@69:             set my_info [$tmp_win configure $opt]
jpayne@69:             set resource [lindex $my_info 1]
jpayne@69:             set class [lindex $my_info 2]
jpayne@69:             set default_val [lindex $my_info 3]
jpayne@69: 	    uplevel #0 destroy $tmp_win
jpayne@69:             set found 1
jpayne@69:         }
jpayne@69: 	if {$found} {
jpayne@69:            if {[catch {
jpayne@69:                set val [uplevel #0 ::option get $win $resource $class]
jpayne@69:            } msg]} {
jpayne@69:                set val ""
jpayne@69:            }
jpayne@69:            if {[::dict exists $argsDict $opt]} {
jpayne@69:                # we have an explicitly set option
jpayne@69:                set val [::dict get $argsDict $opt]
jpayne@69:            } else {
jpayne@69: 	       if {[string length $val] == 0} {
jpayne@69:                    set val $default_val
jpayne@69: 	       }
jpayne@69:            }
jpayne@69:            set ::itcl::internal::variables::${my_win}::itcl_options($opt) $val
jpayne@69:            set ::itcl::internal::variables::${my_win}::__itcl_option_infos($opt) [list $resource $class $default_val]
jpayne@69: #puts stderr "OPT1!$opt!$val!"
jpayne@69: #	   uplevel 1 [list set itcl_options($opt) [list $val]]
jpayne@69:            if {[catch {uplevel 1 $win configure $opt [list $val]} msg]} {
jpayne@69: #puts stderr "addToItclOptions ERR!$msg!$my_class!$win!configure!$opt!$val!"
jpayne@69: 	   }
jpayne@69:         }
jpayne@69:     }
jpayne@69: }
jpayne@69: 
jpayne@69: # ======================= setupcomponent ===========================
jpayne@69: 
jpayne@69: proc setupcomponent {comp using widget_type path args} {
jpayne@69:     upvar this this
jpayne@69:     upvar win win
jpayne@69:     upvar itcl_hull itcl_hull
jpayne@69: 
jpayne@69: #puts stderr "setupcomponent!$comp!$widget_type!$path!$args!$this!$win!$itcl_hull!"
jpayne@69: #puts stderr "CONT![uplevel 1 info context]!"
jpayne@69: #puts stderr "ns1![uplevel 1 namespace current]!"
jpayne@69: #puts stderr "ns2![uplevel 2 namespace current]!"
jpayne@69: #puts stderr "ns3![uplevel 3 namespace current]!"
jpayne@69:     set my_comp_object  [lindex [uplevel 1 info context] 1]
jpayne@69:     if {[::info exists ::itcl::internal::component_objects($my_comp_object)]} {
jpayne@69:         set my_comp_object [set ::itcl::internal::component_objects($my_comp_object)]
jpayne@69:     } else {
jpayne@69:         set ::itcl::internal::component_objects($path) $my_comp_object
jpayne@69:     }
jpayne@69:     set options [list]
jpayne@69:     foreach {option_name value} $args {
jpayne@69:         switch -glob -- $option_name {
jpayne@69:         -* {
jpayne@69:             lappend options $option_name $value
jpayne@69:           }
jpayne@69:         default {
jpayne@69: 	    return -code error "bad option name\"$option_name\" options must start with a \"-\""
jpayne@69:           }
jpayne@69:         }
jpayne@69:     }
jpayne@69:     if {[llength $args]} {
jpayne@69:         set argsDict [dict create {*}$args]
jpayne@69:     } else {
jpayne@69:         set argsDict [dict create]
jpayne@69:     }
jpayne@69:     set cmd [list $widget_type $path]
jpayne@69:     if {[llength $options] > 0} {
jpayne@69:         lappend cmd {*}$options
jpayne@69:     }
jpayne@69: #puts stderr "cmd0![::info command $widget_type]!$path![::info command $path]!"
jpayne@69: #puts stderr "cmd1!$cmd!"
jpayne@69: #    set my_comp [uplevel 3 $cmd]
jpayne@69:     set my_comp [uplevel #0 $cmd]
jpayne@69: #puts stderr 111![::info command $path]!
jpayne@69:     ::itcl::setcomponent $this $comp $my_comp
jpayne@69:     set opts [uplevel 1 info delegated options]
jpayne@69:     foreach entry $opts {
jpayne@69:         foreach {optName compName} $entry break
jpayne@69: 	if {$compName eq $my_comp} {
jpayne@69: 	    set optInfos [uplevel 1 info delegated option $optName]
jpayne@69: 	    set realOptName [lindex $optInfos 4]
jpayne@69: 	    # strip off the "-" at the beginning
jpayne@69: 	    set myOptName [string range $realOptName 1 end]
jpayne@69:             set my_opt_val [option get $my_win $myOptName *]
jpayne@69:             if {$my_opt_val ne ""} {
jpayne@69:                 $my_comp configure -$myOptName $my_opt_val
jpayne@69:             }
jpayne@69: 	}
jpayne@69:     }
jpayne@69:     set my_class $widget_type
jpayne@69:     set my_parent_class [uplevel 1 namespace current]
jpayne@69:     if {[catch {
jpayne@69:         set myOptions [namespace eval $my_class {info classoptions}]
jpayne@69:     } msg]} {
jpayne@69:         set myOptions [list]
jpayne@69:     }
jpayne@69:     foreach entry [$path configure] {
jpayne@69:         foreach {opt dummy1 dummy2 dummy3} $entry break
jpayne@69:         lappend myOptions $opt
jpayne@69:     }
jpayne@69: #puts stderr "OPTS!$myOptions!"
jpayne@69:     addToItclOptions $widget_type $my_comp_object $myOptions $argsDict
jpayne@69: #puts stderr END!$path![::info command $path]!
jpayne@69: }
jpayne@69: 
jpayne@69: proc itcl_initoptions {args} {
jpayne@69: puts stderr "ITCL_INITOPT!$args!"
jpayne@69: }
jpayne@69: 
jpayne@69: # ======================= initoptions ===========================
jpayne@69: 
jpayne@69: proc initoptions {args} {
jpayne@69:     upvar win win
jpayne@69:     upvar itcl_hull itcl_hull
jpayne@69:     upvar itcl_option_components itcl_option_components
jpayne@69: 
jpayne@69: #puts stderr "INITOPT!!$win!"
jpayne@69:     if {[llength $args]} {
jpayne@69:         set argsDict [dict create {*}$args]
jpayne@69:     } else {
jpayne@69:         set argsDict [dict create]
jpayne@69:     }
jpayne@69:     set my_class [uplevel 1 namespace current]
jpayne@69:     set myOptions [namespace eval $my_class {info classoptions}]
jpayne@69:     if {[dict exists $::itcl::internal::dicts::classComponents $my_class]} {
jpayne@69:         set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class]
jpayne@69: #    set myOptions [lsort -unique [namespace eval $my_class {info options}]]
jpayne@69:         foreach comp [uplevel 1 info components] {
jpayne@69:            if {[dict exists $class_info_dict $comp -keptoptions]} {
jpayne@69:                foreach my_opt [dict get $class_info_dict $comp -keptoptions] {
jpayne@69:                    if {[lsearch $myOptions $my_opt] < 0} {
jpayne@69: #puts stderr "KEOPT!$my_opt!"
jpayne@69:                        lappend myOptions $my_opt
jpayne@69:                    }
jpayne@69:                }
jpayne@69:            }
jpayne@69:         }
jpayne@69:     } else {
jpayne@69:         set class_info_dict [list]
jpayne@69:     }
jpayne@69: #puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!"
jpayne@69:     set opt_lst [list configure]
jpayne@69:     set my_win $win
jpayne@69:     foreach opt [lsort $myOptions] {
jpayne@69: 	set found 0
jpayne@69:         if {[catch {
jpayne@69:             set resource [uplevel 1 info option $opt -resource]
jpayne@69:             set class [uplevel 1 info option $opt -class]
jpayne@69:             set default_val [uplevel 1 info option $opt -default]
jpayne@69: 	    set found 1
jpayne@69:         } msg]} {
jpayne@69: #            puts stderr "MSG!$opt!$msg!"
jpayne@69:         }
jpayne@69: #puts stderr "OPT!$opt!$found!"
jpayne@69: 	if {$found} {
jpayne@69:            if {[catch {
jpayne@69:                set val [uplevel #0 ::option get $my_win $resource $class]
jpayne@69:            } msg]} {
jpayne@69:                set val ""
jpayne@69:            }
jpayne@69:            if {[::dict exists $argsDict $opt]} {
jpayne@69:                # we have an explicitly set option
jpayne@69:                set val [::dict get $argsDict $opt]
jpayne@69:            } else {
jpayne@69: 	       if {[string length $val] == 0} {
jpayne@69:                    set val $default_val
jpayne@69: 	       }
jpayne@69:            }
jpayne@69:            set ::itcl::internal::variables::${win}::itcl_options($opt) $val
jpayne@69:            set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val]
jpayne@69: #puts stderr "OPT1!$opt!$val!"
jpayne@69: #	   uplevel 1 [list set itcl_options($opt) [list $val]]
jpayne@69:            if {[catch {uplevel 1 $my_win configure $opt [list $val]} msg]} {
jpayne@69: puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!"
jpayne@69: 	   }
jpayne@69:         }
jpayne@69:         foreach comp [dict keys $class_info_dict] {
jpayne@69: #puts stderr "OPT1!$opt!$comp![dict get $class_info_dict $comp]!"
jpayne@69:             if {[dict exists $class_info_dict $comp -keptoptions]} {
jpayne@69:                 if {[lsearch [dict get $class_info_dict $comp -keptoptions] $opt] >= 0} {
jpayne@69:                     if {$found == 0} {
jpayne@69:                         # we use the option value of the first component for setting
jpayne@69:                         # the option, as the components are traversed in the dict
jpayne@69:                         # depending on the ordering of the component creation!!
jpayne@69:                         set my_info [uplevel 1 \[set $comp\] configure $opt]
jpayne@69:                         set resource [lindex $my_info 1]
jpayne@69:                         set class [lindex $my_info 2]
jpayne@69:                         set default_val [lindex $my_info 3]
jpayne@69:                         set found 2
jpayne@69:                         set val [uplevel #0 ::option get $my_win $resource $class]
jpayne@69:                         if {[::dict exists $argsDict $opt]} {
jpayne@69:                             # we have an explicitly set option
jpayne@69:                             set val [::dict get $argsDict $opt]
jpayne@69:                         } else {
jpayne@69: 	                    if {[string length $val] == 0} {
jpayne@69:                                 set val $default_val
jpayne@69: 	                    }
jpayne@69:                         }
jpayne@69: #puts stderr "OPT2!$opt!$val!"
jpayne@69: 		        set ::itcl::internal::variables::${win}::itcl_options($opt) $val
jpayne@69: 		        set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val]
jpayne@69: #	                uplevel 1 [list set itcl_options($opt) [list $val]]
jpayne@69:                     }
jpayne@69:                     if {[catch {uplevel 1 \[set $comp\] configure $opt [list $val]} msg]} {
jpayne@69: puts stderr "initoptions ERR2!$msg!$my_class!$comp!configure!$opt!$val!"
jpayne@69: 	            }
jpayne@69: 		    if {![uplevel 1 info exists itcl_option_components($opt)]} {
jpayne@69:                         set itcl_option_components($opt) [list]
jpayne@69: 		    }
jpayne@69: 		    if {[lsearch [set itcl_option_components($opt)] $comp] < 0} {
jpayne@69: 		        if {![catch {
jpayne@69: 		            set optval [uplevel 1 [list set itcl_options($opt)]]
jpayne@69:                         } msg3]} {
jpayne@69:                                 uplevel 1 \[set $comp\] configure $opt $optval
jpayne@69:                         }
jpayne@69:                         lappend itcl_option_components($opt) $comp
jpayne@69: 		    }
jpayne@69:                 }
jpayne@69:             }
jpayne@69:         }
jpayne@69:     }
jpayne@69: #    uplevel 1 $opt_lst
jpayne@69: }
jpayne@69: 
jpayne@69: # ======================= setoptions ===========================
jpayne@69: 
jpayne@69: proc setoptions {args} {
jpayne@69: 
jpayne@69: #puts stderr "setOPT!!$args!"
jpayne@69:     if {[llength $args]} {
jpayne@69:         set argsDict [dict create {*}$args]
jpayne@69:     } else {
jpayne@69:         set argsDict [dict create]
jpayne@69:     }
jpayne@69:     set my_class [uplevel 1 namespace current]
jpayne@69:     set myOptions [namespace eval $my_class {info options}]
jpayne@69: #puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!"
jpayne@69:     set opt_lst [list configure]
jpayne@69:     foreach opt [lsort $myOptions] {
jpayne@69: 	set found 0
jpayne@69:         if {[catch {
jpayne@69:             set resource [uplevel 1 info option $opt -resource]
jpayne@69:             set class [uplevel 1 info option $opt -class]
jpayne@69:             set default_val [uplevel 1 info option $opt -default]
jpayne@69: 	    set found 1
jpayne@69:         } msg]} {
jpayne@69: #            puts stderr "MSG!$opt!$msg!"
jpayne@69:         }
jpayne@69: #puts stderr "OPT!$opt!$found!"
jpayne@69: 	if {$found} {
jpayne@69:            set val ""
jpayne@69:            if {[::dict exists $argsDict $opt]} {
jpayne@69:                # we have an explicitly set option
jpayne@69:                set val [::dict get $argsDict $opt]
jpayne@69:            } else {
jpayne@69: 	       if {[string length $val] == 0} {
jpayne@69:                    set val $default_val
jpayne@69: 	       }
jpayne@69:            }
jpayne@69: 	   set myObj [uplevel 1 set this]
jpayne@69: #puts stderr "myObj!$myObj!"
jpayne@69:            set ::itcl::internal::variables::${myObj}::itcl_options($opt) $val
jpayne@69:            set ::itcl::internal::variables::${myObj}::__itcl_option_infos($opt) [list $resource $class $default_val]
jpayne@69: #puts stderr "OPT1!$opt!$val!"
jpayne@69: 	   uplevel 1 [list set itcl_options($opt) [list $val]]
jpayne@69: #           if {[catch {uplevel 1 $myObj configure $opt [list $val]} msg]} {
jpayne@69: #puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!"
jpayne@69: #	   }
jpayne@69:         }
jpayne@69:     }
jpayne@69: #    uplevel 1 $opt_lst
jpayne@69: }
jpayne@69: 
jpayne@69: # ========================= keepcomponentoption ======================
jpayne@69: #  Invoked by Tcl during evaluating constructor whenever
jpayne@69: #  the "keepcomponentoption" command is invoked to list the options
jpayne@69: #  to be kept when an ::itcl::extendedclass component has been setup
jpayne@69: #  for an object.
jpayne@69: #
jpayne@69: #  It checks, for all arguments, if the opt is an option of that class
jpayne@69: #  and of that component. If that is the case it adds the component name
jpayne@69: #  to the list of components for that option.
jpayne@69: #  The variable is the object variable: itcl_option_components($opt)
jpayne@69: #
jpayne@69: #  Handles the following syntax:
jpayne@69: #
jpayne@69: #    keepcomponentoption <componentName> <optionName> ?<optionName> ...?
jpayne@69: #
jpayne@69: # ======================================================================
jpayne@69: 
jpayne@69: 
jpayne@69: proc keepcomponentoption {args} {
jpayne@69:     upvar win win
jpayne@69:     upvar itcl_hull itcl_hull
jpayne@69: 
jpayne@69:     set usage "wrong # args, should be: keepcomponentoption componentName optionName ?optionName ...?"
jpayne@69: 
jpayne@69: #puts stderr "KEEP!$args![uplevel 1 namespace current]!"
jpayne@69:     if {[llength $args] < 2} {
jpayne@69:         puts stderr $usage
jpayne@69: 	return -code error
jpayne@69:     }
jpayne@69:     set my_hull [uplevel 1 set itcl_hull]
jpayne@69:     set my_class [uplevel 1 namespace current]
jpayne@69:     set comp [lindex $args 0]
jpayne@69:     set args [lrange $args 1 end]
jpayne@69:     set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class]
jpayne@69:     if {![dict exists $class_info_dict $comp]} {
jpayne@69:         puts stderr "keepcomponentoption cannot find component \"$comp\""
jpayne@69: 	return -code error
jpayne@69:     }
jpayne@69:     set class_comp_dict [dict get $class_info_dict $comp]
jpayne@69:     if {![dict exists $class_comp_dict -keptoptions]} {
jpayne@69:         dict set class_comp_dict -keptoptions [list]
jpayne@69:     }
jpayne@69:     foreach opt $args {
jpayne@69: #puts stderr "KEEP!$opt!"
jpayne@69: 	if {[string range $opt 0 0] ne "-"} {
jpayne@69:             puts stderr "keepcomponentoption: option must begin with a \"-\"!"
jpayne@69: 	    return -code error
jpayne@69: 	}
jpayne@69:         if {[lsearch [dict get $class_comp_dict -keptoptions] $opt] < 0} {
jpayne@69:             dict lappend class_comp_dict -keptoptions $opt
jpayne@69: 	}
jpayne@69:     }
jpayne@69:     if {![info exists ::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])]} {
jpayne@69:         set comp_object $::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])
jpayne@69:     } else {
jpayne@69:         set comp_object "unknown_comp_obj_$comp!"
jpayne@69:     }
jpayne@69:     dict set class_info_dict $comp $class_comp_dict
jpayne@69:     dict set ::itcl::internal::dicts::classComponents $my_class $class_info_dict
jpayne@69: puts stderr "CLDI!$class_comp_dict!"
jpayne@69:     addToItclOptions $my_class $comp_object $args [list]
jpayne@69: }
jpayne@69: 
jpayne@69: proc ignorecomponentoption {args} {
jpayne@69: puts stderr "IGNORE_COMPONENT_OPTION!$args!"
jpayne@69: }
jpayne@69: 
jpayne@69: proc renamecomponentoption {args} {
jpayne@69: puts stderr "rename_COMPONENT_OPTION!$args!"
jpayne@69: }
jpayne@69: 
jpayne@69: proc addoptioncomponent {args} {
jpayne@69: puts stderr "ADD_OPTION_COMPONENT!$args!"
jpayne@69: }
jpayne@69: 
jpayne@69: proc ignoreoptioncomponent {args} {
jpayne@69: puts stderr "IGNORE_OPTION_COMPONENT!$args!"
jpayne@69: }
jpayne@69: 
jpayne@69: proc renameoptioncomponent {args} {
jpayne@69: puts stderr "RENAME_OPTION_COMPONENT!$args!"
jpayne@69: }
jpayne@69: 
jpayne@69: proc getEclassOptions {args} {
jpayne@69:     upvar win win
jpayne@69: 
jpayne@69: #puts stderr "getEclassOptions!$args!$win![uplevel 1 namespace current]!"
jpayne@69: #parray ::itcl::internal::variables::${win}::itcl_options
jpayne@69:     set result [list]
jpayne@69:     foreach opt [array names ::itcl::internal::variables::${win}::itcl_options] {
jpayne@69:         if {[catch {
jpayne@69:             foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break
jpayne@69:             lappend result [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]]
jpayne@69:         } msg]} {
jpayne@69:         }
jpayne@69:     }
jpayne@69:     return $result
jpayne@69: }
jpayne@69: 
jpayne@69: proc eclassConfigure {args} {
jpayne@69:     upvar win win
jpayne@69: 
jpayne@69: #puts stderr "+++ eclassConfigure!$args!"
jpayne@69:     if {[llength $args] > 1} {
jpayne@69:         foreach {opt val}  $args break
jpayne@69:         if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} {
jpayne@69:             set ::itcl::internal::variables::${win}::itcl_options($opt) $val
jpayne@69: 	    return
jpayne@69:         }
jpayne@69:     } else {
jpayne@69:         foreach {opt}  $args break
jpayne@69:         if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} {
jpayne@69: #puts stderr "OP![set ::itcl::internal::variables::${win}::itcl_options($opt)]!"
jpayne@69:             foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break
jpayne@69:             return [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]]
jpayne@69:         }
jpayne@69:     }
jpayne@69:     return -code error
jpayne@69: }
jpayne@69: 
jpayne@69: }