util/X86LINUX64/lib/itcl4.0.3/itclHullCmds.tcl

   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 }