"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tltcl/lib/itcl4.2.0/itclHullCmds.tcl" (17 Mar 2020, 21056 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 #
    2 # itclHullCmds.tcl
    3 # ----------------------------------------------------------------------
    4 # Invoked automatically upon startup to customize the interpreter
    5 # for [incr Tcl] when one of setupcomponent or createhull is called.
    6 # ----------------------------------------------------------------------
    7 #   AUTHOR:  Arnulf P. Wiedemann
    8 #
    9 # ----------------------------------------------------------------------
   10 #            Copyright (c) 2008  Arnulf P. Wiedemann
   11 # ======================================================================
   12 # See the file "license.terms" for information on usage and
   13 # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
   14 
   15 package require Tk 8.6
   16 
   17 namespace eval ::itcl::internal::commands {
   18 
   19 # ======================= widgetDeleted ===========================
   20 
   21 proc widgetDeleted {oldName newName op} {
   22     # The widget is beeing deleted, so we have to delete the object
   23     # which had the widget as itcl_hull too!
   24     # We have to get the real name from for example
   25     # ::itcl::internal::widgets::hull1.lw
   26     # we need only .lw here
   27 
   28 #puts stderr "widgetDeleted!$oldName!$newName!$op!"
   29     set cmdName [namespace tail $oldName]
   30     set flds [split $cmdName {.}]
   31     set cmdName .[join [lrange $flds 1 end] {.}]
   32 #puts stderr "DELWIDGET![namespace current]!$cmdName![::info command $cmdName]!"
   33     rename $cmdName {}
   34 }
   35 
   36 }
   37 
   38 namespace eval ::itcl::builtin {
   39 
   40 # ======================= createhull ===========================
   41 # the hull widget is a tk widget which is the (mega) widget handled behind the itcl
   42 # extendedclass/itcl widget.
   43 # It is created be renaming the itcl class object to a temporary name <itcl object name>_
   44 # creating the widget with the
   45 # appropriate options and the installing that as the "hull" widget (the container)
   46 # All the options in args and the options delegated to component itcl_hull are used
   47 # Then a unique name (hull_widget_name) in the itcl namespace is created for widget:
   48 # ::itcl::internal::widgets::hull<unique number><namespace tail path>
   49 # and widget is renamed to that name
   50 # Finally the <itcl object name>_ is renamed to the original <itcl object name> again
   51 # Component itcl_hull is created if not existent
   52 # itcl_hull is set to the hull_widget_name and the <itcl object name>
   53 # is returned to the caller
   54 # ==============================================================
   55 
   56 proc createhull {widget_type path args} {
   57     variable hullCount
   58     upvar this this
   59     upvar win win
   60 
   61 
   62 #puts stderr "il-1![::info level -1]!$this!"
   63 #puts stderr "createhull!$widget_type!$path!$args!$this![::info command $this]!"
   64 #puts stderr "ns1![uplevel 1 namespace current]!"
   65 #puts stderr "ns2![uplevel 2 namespace current]!"
   66 #puts stderr "ns3![uplevel 3 namespace current]!"
   67 #puts stderr "level-1![::info level -1]!"
   68 #puts stderr "level-2![::info level -2]!"
   69 #    set my_this [namespace tail $this]
   70     set my_this $this
   71     set tmp $my_this
   72 #puts stderr "II![::info command $this]![::info command $tmp]!"
   73 #puts stderr "rename1!rename $my_this ${tmp}_!"
   74     rename ::$my_this ${tmp}_
   75     set options [list]
   76     foreach {option_name value} $args {
   77         switch -glob -- $option_name {
   78     -class {
   79           lappend options $option_name [namespace tail $value]
   80       }
   81         -* {
   82             lappend options $option_name $value
   83           }
   84         default {
   85         return -code error "bad option name\"$option_name\" options must start with a \"-\""
   86           }
   87         }
   88     }
   89     set my_win [namespace tail $path]
   90     set cmd [list $widget_type $my_win]
   91 #puts stderr "my_win!$my_win!cmd!$cmd!$path!"
   92     if {[llength $options] > 0} {
   93         lappend cmd {*}$options
   94     }
   95     set widget [uplevel 1 $cmd]
   96 #puts stderr "widget!$widget!"
   97     trace add command $widget delete ::itcl::internal::commands::widgetDeleted
   98     set opts [uplevel 1 info delegated options]
   99     foreach entry $opts {
  100         foreach {optName compName} $entry break
  101     if {$compName eq "itcl_hull"} {
  102         set optInfos [uplevel 1 info delegated option $optName]
  103         set realOptName [lindex $optInfos 4]
  104         # strip off the "-" at the beginning
  105         set myOptName [string range $realOptName 1 end]
  106             set my_opt_val [option get $my_win $myOptName *]
  107             if {$my_opt_val ne ""} {
  108                 $my_win configure -$myOptName $my_opt_val
  109             }
  110     }
  111     }
  112     set idx 1
  113     while {1} {
  114         set widgetName ::itcl::internal::widgets::hull${idx}$my_win
  115 #puts stderr "widgetName!$widgetName!"
  116     if {[string length [::info command $widgetName]] == 0} {
  117         break
  118     }
  119         incr idx
  120     }
  121 #puts stderr "rename2!rename $widget $widgetName!"
  122     set dorename 0
  123     rename $widget $widgetName
  124 #puts stderr "rename3!rename ${tmp}_ $tmp![::info command ${tmp}_]!my_this!$my_this!"
  125     rename ${tmp}_ ::$tmp
  126     set exists [uplevel 1 ::info exists itcl_hull]
  127     if {!$exists} {
  128     # that does not yet work, beacause of problems with resolving
  129         ::itcl::addcomponent $my_this itcl_hull
  130     }
  131     upvar itcl_hull itcl_hull
  132     ::itcl::setcomponent $my_this itcl_hull $widgetName
  133 #puts stderr "IC![::info command $my_win]!"
  134     set exists [uplevel 1 ::info exists itcl_interior]
  135     if {!$exists} {
  136     # that does not yet work, beacause of problems with resolving
  137         ::itcl::addcomponent $this itcl_interior
  138     }
  139     upvar itcl_interior itcl_interior
  140     set itcl_interior $my_win
  141 #puts stderr "hull end!win!$win!itcl_hull!$itcl_hull!itcl_interior!$itcl_interior!"
  142     return $my_win
  143 }
  144 
  145 # ======================= addToItclOptions ===========================
  146 
  147 proc addToItclOptions {my_class my_win myOptions argsDict} {
  148     upvar win win
  149     upvar itcl_hull itcl_hull
  150 
  151     set opt_lst [list configure]
  152     foreach opt [lsort $myOptions] {
  153 #puts stderr "IOPT!$opt!$my_class!$my_win![::itcl::is class $my_class]!"
  154         set isClass [::itcl::is class $my_class]
  155     set found 0
  156     if {$isClass} {
  157             if {[catch {
  158                 set resource [namespace eval $my_class info option $opt -resource]
  159                 set class [namespace eval $my_class info option $opt -class]
  160                 set default_val [uplevel 2 info option $opt -default]
  161                 set found 1
  162             } msg]} {
  163 #                puts stderr "MSG!$opt!$my_class!$msg!"
  164             }
  165         } else {
  166             set tmp_win [uplevel #0 $my_class .___xx]
  167 
  168             set my_info [$tmp_win configure $opt]
  169             set resource [lindex $my_info 1]
  170             set class [lindex $my_info 2]
  171             set default_val [lindex $my_info 3]
  172         uplevel #0 destroy $tmp_win
  173             set found 1
  174         }
  175     if {$found} {
  176            if {[catch {
  177                set val [uplevel #0 ::option get $win $resource $class]
  178            } msg]} {
  179                set val ""
  180            }
  181            if {[::dict exists $argsDict $opt]} {
  182                # we have an explicitly set option
  183                set val [::dict get $argsDict $opt]
  184            } else {
  185            if {[string length $val] == 0} {
  186                    set val $default_val
  187            }
  188            }
  189            set ::itcl::internal::variables::${my_win}::itcl_options($opt) $val
  190            set ::itcl::internal::variables::${my_win}::__itcl_option_infos($opt) [list $resource $class $default_val]
  191 #puts stderr "OPT1!$opt!$val!"
  192 #      uplevel 1 [list set itcl_options($opt) [list $val]]
  193            if {[catch {uplevel 1 $win configure $opt [list $val]} msg]} {
  194 #puts stderr "addToItclOptions ERR!$msg!$my_class!$win!configure!$opt!$val!"
  195        }
  196         }
  197     }
  198 }
  199 
  200 # ======================= setupcomponent ===========================
  201 
  202 proc setupcomponent {comp using widget_type path args} {
  203     upvar this this
  204     upvar win win
  205     upvar itcl_hull itcl_hull
  206 
  207 #puts stderr "setupcomponent!$comp!$widget_type!$path!$args!$this!$win!$itcl_hull!"
  208 #puts stderr "CONT![uplevel 1 info context]!"
  209 #puts stderr "ns1![uplevel 1 namespace current]!"
  210 #puts stderr "ns2![uplevel 2 namespace current]!"
  211 #puts stderr "ns3![uplevel 3 namespace current]!"
  212     set my_comp_object  [lindex [uplevel 1 info context] 1]
  213     if {[::info exists ::itcl::internal::component_objects($my_comp_object)]} {
  214         set my_comp_object [set ::itcl::internal::component_objects($my_comp_object)]
  215     } else {
  216         set ::itcl::internal::component_objects($path) $my_comp_object
  217     }
  218     set options [list]
  219     foreach {option_name value} $args {
  220         switch -glob -- $option_name {
  221         -* {
  222             lappend options $option_name $value
  223           }
  224         default {
  225         return -code error "bad option name\"$option_name\" options must start with a \"-\""
  226           }
  227         }
  228     }
  229     if {[llength $args]} {
  230         set argsDict [dict create {*}$args]
  231     } else {
  232         set argsDict [dict create]
  233     }
  234     set cmd [list $widget_type $path]
  235     if {[llength $options] > 0} {
  236         lappend cmd {*}$options
  237     }
  238 #puts stderr "cmd0![::info command $widget_type]!$path![::info command $path]!"
  239 #puts stderr "cmd1!$cmd!"
  240 #    set my_comp [uplevel 3 $cmd]
  241     set my_comp [uplevel #0 $cmd]
  242 #puts stderr 111![::info command $path]!
  243     ::itcl::setcomponent $this $comp $my_comp
  244     set opts [uplevel 1 info delegated options]
  245     foreach entry $opts {
  246         foreach {optName compName} $entry break
  247     if {$compName eq $my_comp} {
  248         set optInfos [uplevel 1 info delegated option $optName]
  249         set realOptName [lindex $optInfos 4]
  250         # strip off the "-" at the beginning
  251         set myOptName [string range $realOptName 1 end]
  252             set my_opt_val [option get $my_win $myOptName *]
  253             if {$my_opt_val ne ""} {
  254                 $my_comp configure -$myOptName $my_opt_val
  255             }
  256     }
  257     }
  258     set my_class $widget_type
  259     set my_parent_class [uplevel 1 namespace current]
  260     if {[catch {
  261         set myOptions [namespace eval $my_class {info classoptions}]
  262     } msg]} {
  263         set myOptions [list]
  264     }
  265     foreach entry [$path configure] {
  266         foreach {opt dummy1 dummy2 dummy3} $entry break
  267         lappend myOptions $opt
  268     }
  269 #puts stderr "OPTS!$myOptions!"
  270     addToItclOptions $widget_type $my_comp_object $myOptions $argsDict
  271 #puts stderr END!$path![::info command $path]!
  272 }
  273 
  274 proc itcl_initoptions {args} {
  275 puts stderr "ITCL_INITOPT!$args!"
  276 }
  277 
  278 # ======================= initoptions ===========================
  279 
  280 proc initoptions {args} {
  281     upvar win win
  282     upvar itcl_hull itcl_hull
  283     upvar itcl_option_components itcl_option_components
  284 
  285 #puts stderr "INITOPT!!$win!"
  286     if {[llength $args]} {
  287         set argsDict [dict create {*}$args]
  288     } else {
  289         set argsDict [dict create]
  290     }
  291     set my_class [uplevel 1 namespace current]
  292     set myOptions [namespace eval $my_class {info classoptions}]
  293     if {[dict exists $::itcl::internal::dicts::classComponents $my_class]} {
  294         set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class]
  295 #    set myOptions [lsort -unique [namespace eval $my_class {info options}]]
  296         foreach comp [uplevel 1 info components] {
  297            if {[dict exists $class_info_dict $comp -keptoptions]} {
  298                foreach my_opt [dict get $class_info_dict $comp -keptoptions] {
  299                    if {[lsearch $myOptions $my_opt] < 0} {
  300 #puts stderr "KEOPT!$my_opt!"
  301                        lappend myOptions $my_opt
  302                    }
  303                }
  304            }
  305         }
  306     } else {
  307         set class_info_dict [list]
  308     }
  309 #puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!"
  310     set opt_lst [list configure]
  311     set my_win $win
  312     foreach opt [lsort $myOptions] {
  313     set found 0
  314         if {[catch {
  315             set resource [uplevel 1 info option $opt -resource]
  316             set class [uplevel 1 info option $opt -class]
  317             set default_val [uplevel 1 info option $opt -default]
  318         set found 1
  319         } msg]} {
  320 #            puts stderr "MSG!$opt!$msg!"
  321         }
  322 #puts stderr "OPT!$opt!$found!"
  323     if {$found} {
  324            if {[catch {
  325                set val [uplevel #0 ::option get $my_win $resource $class]
  326            } msg]} {
  327                set val ""
  328            }
  329            if {[::dict exists $argsDict $opt]} {
  330                # we have an explicitly set option
  331                set val [::dict get $argsDict $opt]
  332            } else {
  333            if {[string length $val] == 0} {
  334                    set val $default_val
  335            }
  336            }
  337            set ::itcl::internal::variables::${win}::itcl_options($opt) $val
  338            set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val]
  339 #puts stderr "OPT1!$opt!$val!"
  340 #      uplevel 1 [list set itcl_options($opt) [list $val]]
  341            if {[catch {uplevel 1 $my_win configure $opt [list $val]} msg]} {
  342 puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!"
  343        }
  344         }
  345         foreach comp [dict keys $class_info_dict] {
  346 #puts stderr "OPT1!$opt!$comp![dict get $class_info_dict $comp]!"
  347             if {[dict exists $class_info_dict $comp -keptoptions]} {
  348                 if {[lsearch [dict get $class_info_dict $comp -keptoptions] $opt] >= 0} {
  349                     if {$found == 0} {
  350                         # we use the option value of the first component for setting
  351                         # the option, as the components are traversed in the dict
  352                         # depending on the ordering of the component creation!!
  353                         set my_info [uplevel 1 \[set $comp\] configure $opt]
  354                         set resource [lindex $my_info 1]
  355                         set class [lindex $my_info 2]
  356                         set default_val [lindex $my_info 3]
  357                         set found 2
  358                         set val [uplevel #0 ::option get $my_win $resource $class]
  359                         if {[::dict exists $argsDict $opt]} {
  360                             # we have an explicitly set option
  361                             set val [::dict get $argsDict $opt]
  362                         } else {
  363                         if {[string length $val] == 0} {
  364                                 set val $default_val
  365                         }
  366                         }
  367 #puts stderr "OPT2!$opt!$val!"
  368                 set ::itcl::internal::variables::${win}::itcl_options($opt) $val
  369                 set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val]
  370 #                   uplevel 1 [list set itcl_options($opt) [list $val]]
  371                     }
  372                     if {[catch {uplevel 1 \[set $comp\] configure $opt [list $val]} msg]} {
  373 puts stderr "initoptions ERR2!$msg!$my_class!$comp!configure!$opt!$val!"
  374                 }
  375             if {![uplevel 1 info exists itcl_option_components($opt)]} {
  376                         set itcl_option_components($opt) [list]
  377             }
  378             if {[lsearch [set itcl_option_components($opt)] $comp] < 0} {
  379                 if {![catch {
  380                     set optval [uplevel 1 [list set itcl_options($opt)]]
  381                         } msg3]} {
  382                                 uplevel 1 \[set $comp\] configure $opt $optval
  383                         }
  384                         lappend itcl_option_components($opt) $comp
  385             }
  386                 }
  387             }
  388         }
  389     }
  390 #    uplevel 1 $opt_lst
  391 }
  392 
  393 # ======================= setoptions ===========================
  394 
  395 proc setoptions {args} {
  396 
  397 #puts stderr "setOPT!!$args!"
  398     if {[llength $args]} {
  399         set argsDict [dict create {*}$args]
  400     } else {
  401         set argsDict [dict create]
  402     }
  403     set my_class [uplevel 1 namespace current]
  404     set myOptions [namespace eval $my_class {info options}]
  405 #puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!"
  406     set opt_lst [list configure]
  407     foreach opt [lsort $myOptions] {
  408     set found 0
  409         if {[catch {
  410             set resource [uplevel 1 info option $opt -resource]
  411             set class [uplevel 1 info option $opt -class]
  412             set default_val [uplevel 1 info option $opt -default]
  413         set found 1
  414         } msg]} {
  415 #            puts stderr "MSG!$opt!$msg!"
  416         }
  417 #puts stderr "OPT!$opt!$found!"
  418     if {$found} {
  419            set val ""
  420            if {[::dict exists $argsDict $opt]} {
  421                # we have an explicitly set option
  422                set val [::dict get $argsDict $opt]
  423            } else {
  424            if {[string length $val] == 0} {
  425                    set val $default_val
  426            }
  427            }
  428        set myObj [uplevel 1 set this]
  429 #puts stderr "myObj!$myObj!"
  430            set ::itcl::internal::variables::${myObj}::itcl_options($opt) $val
  431            set ::itcl::internal::variables::${myObj}::__itcl_option_infos($opt) [list $resource $class $default_val]
  432 #puts stderr "OPT1!$opt!$val!"
  433        uplevel 1 [list set itcl_options($opt) [list $val]]
  434 #           if {[catch {uplevel 1 $myObj configure $opt [list $val]} msg]} {
  435 #puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!"
  436 #      }
  437         }
  438     }
  439 #    uplevel 1 $opt_lst
  440 }
  441 
  442 # ========================= keepcomponentoption ======================
  443 #  Invoked by Tcl during evaluating constructor whenever
  444 #  the "keepcomponentoption" command is invoked to list the options
  445 #  to be kept when an ::itcl::extendedclass component has been setup
  446 #  for an object.
  447 #
  448 #  It checks, for all arguments, if the opt is an option of that class
  449 #  and of that component. If that is the case it adds the component name
  450 #  to the list of components for that option.
  451 #  The variable is the object variable: itcl_option_components($opt)
  452 #
  453 #  Handles the following syntax:
  454 #
  455 #    keepcomponentoption <componentName> <optionName> ?<optionName> ...?
  456 #
  457 # ======================================================================
  458 
  459 
  460 proc keepcomponentoption {args} {
  461     upvar win win
  462     upvar itcl_hull itcl_hull
  463 
  464     set usage "wrong # args, should be: keepcomponentoption componentName optionName ?optionName ...?"
  465 
  466 #puts stderr "KEEP!$args![uplevel 1 namespace current]!"
  467     if {[llength $args] < 2} {
  468         puts stderr $usage
  469     return -code error
  470     }
  471     set my_hull [uplevel 1 set itcl_hull]
  472     set my_class [uplevel 1 namespace current]
  473     set comp [lindex $args 0]
  474     set args [lrange $args 1 end]
  475     set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class]
  476     if {![dict exists $class_info_dict $comp]} {
  477         puts stderr "keepcomponentoption cannot find component \"$comp\""
  478     return -code error
  479     }
  480     set class_comp_dict [dict get $class_info_dict $comp]
  481     if {![dict exists $class_comp_dict -keptoptions]} {
  482         dict set class_comp_dict -keptoptions [list]
  483     }
  484     foreach opt $args {
  485 #puts stderr "KEEP!$opt!"
  486     if {[string range $opt 0 0] ne "-"} {
  487             puts stderr "keepcomponentoption: option must begin with a \"-\"!"
  488         return -code error
  489     }
  490         if {[lsearch [dict get $class_comp_dict -keptoptions] $opt] < 0} {
  491             dict lappend class_comp_dict -keptoptions $opt
  492     }
  493     }
  494     if {![info exists ::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])]} {
  495         set comp_object $::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])
  496     } else {
  497         set comp_object "unknown_comp_obj_$comp!"
  498     }
  499     dict set class_info_dict $comp $class_comp_dict
  500     dict set ::itcl::internal::dicts::classComponents $my_class $class_info_dict
  501 puts stderr "CLDI!$class_comp_dict!"
  502     addToItclOptions $my_class $comp_object $args [list]
  503 }
  504 
  505 proc ignorecomponentoption {args} {
  506 puts stderr "IGNORE_COMPONENT_OPTION!$args!"
  507 }
  508 
  509 proc renamecomponentoption {args} {
  510 puts stderr "rename_COMPONENT_OPTION!$args!"
  511 }
  512 
  513 proc addoptioncomponent {args} {
  514 puts stderr "ADD_OPTION_COMPONENT!$args!"
  515 }
  516 
  517 proc ignoreoptioncomponent {args} {
  518 puts stderr "IGNORE_OPTION_COMPONENT!$args!"
  519 }
  520 
  521 proc renameoptioncomponent {args} {
  522 puts stderr "RENAME_OPTION_COMPONENT!$args!"
  523 }
  524 
  525 proc getEclassOptions {args} {
  526     upvar win win
  527 
  528 #puts stderr "getEclassOptions!$args!$win![uplevel 1 namespace current]!"
  529 #parray ::itcl::internal::variables::${win}::itcl_options
  530     set result [list]
  531     foreach opt [array names ::itcl::internal::variables::${win}::itcl_options] {
  532         if {[catch {
  533             foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break
  534             lappend result [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]]
  535         } msg]} {
  536         }
  537     }
  538     return $result
  539 }
  540 
  541 proc eclassConfigure {args} {
  542     upvar win win
  543 
  544 #puts stderr "+++ eclassConfigure!$args!"
  545     if {[llength $args] > 1} {
  546         foreach {opt val}  $args break
  547         if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} {
  548             set ::itcl::internal::variables::${win}::itcl_options($opt) $val
  549         return
  550         }
  551     } else {
  552         foreach {opt}  $args break
  553         if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} {
  554 #puts stderr "OP![set ::itcl::internal::variables::${win}::itcl_options($opt)]!"
  555             foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break
  556             return [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]]
  557         }
  558     }
  559     return -code error
  560 }
  561 
  562 }