buildtool/windows/tools/lib/itcl4.2.2/itclHullCmds.tcl

#
# 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
}

}