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

   1 #
   2 # itclWidget.tcl
   3 # ----------------------------------------------------------------------
   4 # Invoked automatically upon startup to customize the interpreter
   5 # for [incr Tcl] when one of ::itcl::widget or ::itcl::widgetadaptor 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 # package require itclwidget [set ::itcl::version]
  17
  18 namespace eval ::itcl {
  19
  20 proc widget {name args} {
  21     set result [uplevel 1 ::itcl::internal::commands::genericclass widget $name $args]
  22     # we handle create by owerselfs !! allow classunknown to handle that
  23     oo::objdefine $result unexport create
  24     return $result
  25 }
  26
  27 proc widgetadaptor {name args} {
  28     set result [uplevel 1 ::itcl::internal::commands::genericclass widgetadaptor $name $args]
  29     # we handle create by owerselfs !! allow classunknown to handle that
  30     oo::objdefine $result unexport create
  31     return $result
  32 }
  33
  34 } ; # end ::itcl
  35
  36
  37 namespace eval ::itcl::internal::commands {
  38
  39 proc initWidgetOptions {varNsName widgetName className} {
  40     set myDict [set ::itcl::internal::dicts::classOptions]
  41     if {$myDict eq ""} {
  42         return
  43     }
  44     if {![dict exists $myDict $className]} {
  45         return
  46     }
  47     set myDict [dict get $myDict $className]
  48     foreach option [dict keys $myDict] {
  49         set infos [dict get $myDict $option]
  50         set resource [dict get $infos -resource]
  51         set class [dict get $infos -class]
  52         set value [::option get $widgetName $resource $class]
  53         if {$value eq ""} {
  54             if {[dict exists $infos -default]} {
  55                 set defaultValue [dict get $infos -default]
  56                 uplevel 1 set ${varNsName}::itcl_options($option) $defaultValue
  57             }
  58         } else {
  59             uplevel 1 set ${varNsName}::itcl_options($option) $value
  60         }
  61     }
  62 }
  63
  64 proc initWidgetDelegatedOptions {varNsName widgetName className args} {
  65     set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
  66     if {$myDict eq ""} {
  67         return
  68     }
  69     if {![dict exists $myDict $className]} {
  70         return
  71     }
  72     set myDict [dict get $myDict $className]
  73     foreach option [dict keys $myDict] {
  74         set infos [dict get $myDict $option]
  75         if {![dict exists $infos -resource]} {
  76             # this is the case when delegating "*"
  77             continue
  78         }
  79         if {![dict exists $infos -component]} {
  80             # nothing to do
  81             continue
  82         }
  83         # check if not in the command line options
  84         # these have higher priority
  85         set myOption $option
  86         if {[dict exists $infos -as]} {
  87            set myOption [dict get $infos -as]
  88         }
  89         set noOptionSet 0
  90         foreach {optName optVal} $args {
  91             if {$optName eq $myOption} {
  92                 set noOptionSet 1
  93                 break
  94             }
  95         }
  96         if {$noOptionSet} {
  97             continue
  98         }
  99         set resource [dict get $infos -resource]
 100         set class [dict get $infos -class]
 101         set component [dict get $infos -component]
 102         set value [::option get $widgetName $resource $class]
 103         if {$component ne ""} {
 104             if {$value ne ""} {
 105                 set compVar [namespace eval ${varNsName}${className} "set $component"]
 106                 if {$compVar ne ""} {
 107                     uplevel 1 $compVar configure $myOption $value
 108                 }
 109             }
 110         }
 111     }
 112 }
 113
 114 proc widgetinitobjectoptions {varNsName widgetName className} {
 115 #puts stderr "initWidgetObjectOptions!$varNsName!$widgetName!$className!"
 116 }
 117
 118 proc deletehull {newName oldName what} {
 119     if {$what eq "delete"} {
 120         set name [namespace tail $newName]
 121         regsub {hull[0-9]+} $name {} name
 122         rename $name {}
 123     }
 124     if {$what eq "rename"} {
 125         set name [namespace tail $newName]
 126         regsub {hull[0-9]+} $name {} name
 127         rename $name {}
 128     }
 129 }
 130
 131 proc hullandoptionsinstall {objectName className widgetClass hulltype args} {
 132     if {$hulltype eq ""} {
 133         set hulltype frame
 134     }
 135     set idx 0
 136     set found 0
 137     foreach {optName optValue} $args {
 138         if {$optName eq "-class"} {
 139             set found 1
 140             set widgetClass $optValue
 141             break
 142         }
 143         incr idx
 144     }
 145     if {$found} {
 146         set args [lreplace $args $idx [expr {$idx + 1}]]
 147     }
 148     if {$widgetClass eq ""} {
 149         set widgetClass $className
 150         set widgetClass [string totitle $widgetClass]
 151     }
 152     set cmd "set win $objectName; ::itcl::builtin::installhull using $hulltype -class $widgetClass $args"
 153     uplevel 2 $cmd
 154 }
 155
 156 } ; # end ::itcl::internal::commands
 157
 158 namespace eval ::itcl::builtin {
 159
 160 proc installhull {args} {
 161     upvar win win
 162
 163     set cmdPath ::itcl::internal::commands
 164     set className [uplevel 1 info class]
 165     set numArgs [llength $args]
 166     if {$numArgs < 2} {
 167         if {$numArgs != 1} {
 168             error "wrong # args: should be \"installhull name|using <widgetType> ?arg ...?\""
 169         }
 170     }
 171     set shortForm 0
 172     set widgetName $win
 173     set origWidgetName $widgetName
 174     if {$numArgs == 1} {
 175         set shortForm 1
 176         set widgetName [lindex $args 0]
 177     }
 178     set varNsName ::itcl::internal::variables::$widgetName
 179     set myCmd [uplevel 1 ::info command $widgetName]
 180     set haveObject 1
 181     if {$myCmd eq ""} {
 182         set haveObject 0
 183     }
 184     set args [lrange $args 1 end]
 185     if {!$shortForm} {
 186         set widgetType [lindex $args 0]
 187         set args [lrange $args 1 end]
 188         set classNam ""
 189         if {$numArgs > 2} {
 190             set classOpt [lindex $args 0]
 191             if {$classOpt eq "-class"} {
 192                 set classNam [lindex $args 1]
 193                 set args [lrange $args 2 end]
 194             }
 195         }
 196         if {$classNam eq ""} {
 197             set classNam [string totitle $widgetType]
 198         }
 199         uplevel 1 $widgetType $widgetName -class $classNam $args
 200         uplevel 1 ${cmdPath}::initWidgetOptions $varNsName $widgetName $className
 201     }
 202     # initialize the itcl_hull variable
 203     set i 0
 204     set nam ::itcl::internal::widgets::hull
 205     while {1} {
 206          incr i
 207          set hullNam ${nam}${i}$widgetName
 208          if {[::info command $hullNam] eq ""} {
 209              break
 210         }
 211     }
 212     uplevel 1 ${cmdPath}::sethullwindowname $widgetName
 213     uplevel 1 rename $widgetName $hullNam
 214     uplevel 1 trace add command $hullNam \[list delete rename\] ::itcl::internal::commands::deletehull
 215     set objectName [namespace tail $win]
 216     catch {${cmdPath}::checksetitclhull [list] 0}
 217     namespace eval ${varNsName}${className} "set itcl_hull $hullNam"
 218     catch {${cmdPath}::checksetitclhull [list] 2}
 219     set cmd "${cmdPath}::initWidgetDelegatedOptions $varNsName $widgetName $className"
 220     if {$args ne ""} {
 221         append cmd " $args"
 222     }
 223     uplevel 1 $cmd
 224
 225 }
 226
 227 proc installcomponent {args} {
 228     upvar win win
 229
 230     set className [uplevel 1 info class]
 231     set myType [info types [namespace tail $className]]
 232     set isType 0
 233     if {$myType ne ""} {
 234         set isType 1
 235     }
 236     set numArgs [llength $args]
 237     set usage "usage: installcomponent <componentName> using <widgetType> <widgetPath> ?-option value ...?"
 238     if {$numArgs < 4} {
 239         error $usage
 240     }
 241     foreach {componentName using widgetType widgetPath} $args break
 242     set opts [lrange $args 4 end]
 243     if {$using ne "using"} {
 244         error $usage
 245     }
 246     if {!$isType} {
 247         set hullExists [uplevel 1 ::info exists itcl_hull]
 248         if {!$hullExists} {
 249             error "cannot install \"$componentName\" before \"itcl_hull\" exists"
 250         }
 251         set hullVal [uplevel 1 set itcl_hull]
 252         if {$hullVal eq ""} {
 253             error "cannot install \"$componentName\" before \"itcl_hull\" exists"
 254         }
 255     }
 256     # check for delegated option and ask the option database for the values
 257     # first check for number of delegated options
 258     set numOpts 0
 259     set starOption 0
 260     set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
 261     if {[dict exists $myDict $className]} {
 262         set myDict [dict get $myDict $className]
 263         foreach option [dict keys $myDict] {
 264             if {$option eq "*"} {
 265                 set starOption 1
 266             }
 267             incr numOpts
 268         }
 269     }
 270     set myOptionDict [set ::itcl::internal::dicts::classOptions]
 271     if {[dict exists $myOptionDict $className]} {
 272         set myOptionDict [dict get $myOptionDict $className]
 273     }
 274     set cmd [list $widgetPath configure]
 275     set cmd1 "set $componentName \[$widgetType $widgetPath\]"
 276     uplevel 1 $cmd1
 277     if {$starOption} {
 278         upvar $componentName compName
 279         set cmd1 [list $compName configure]
 280         set configInfos [uplevel 1 $cmd1]
 281         foreach entry $configInfos {
 282             if {[llength $entry] > 2} {
 283                 foreach {optName resource class defaultValue} $entry break
 284                 set val ""
 285                 catch {
 286                     set val [::option get $win $resource $class]
 287                 }
 288                 if {$val ne ""} {
 289                     set addOpt 1
 290                     if {[dict exists $myDict $$optName]} {
 291                         set addOpt 0
 292                     } else {
 293                         set starDict [dict get $myDict "*"]
 294                         if {[dict exists $starDict -except]} {
 295                             set exceptions [dict get $starDict -except]
 296                             if {[lsearch $exceptions $optName] >= 0} {
 297                                 set addOpt 0
 298                             }
 299
 300                         }
 301                         if {[dict exists $myOptionDict $optName]} {
 302                             set addOpt 0
 303                         }
 304                     }
 305                     if {$addOpt} {
 306                         lappend cmd $optName $val
 307                     }
 308
 309                 }
 310
 311             }
 312         }
 313     } else {
 314         foreach optName [dict keys $myDict] {
 315             set optInfos [dict get $myDict $optName]
 316             set resource [dict get $optInfos -resource]
 317             set class [namespace tail $className]
 318             set class [string totitle $class]
 319             set val ""
 320             catch {
 321                 set val [::option get $win $resource $class]
 322             }
 323             if {$val ne ""} {
 324                 if {[dict exists $optInfos -as] } {
 325                     set optName [dict get $optInfos -as]
 326                 }
 327                 lappend cmd $optName $val
 328             }
 329         }
 330     }
 331     lappend cmd {*}$opts
 332     uplevel 1 $cmd
 333 }
 334
 335 } ; # end ::itcl::builtin
 336
 337 set ::itcl::internal::dicts::hullTypes [list \
 338        frame \
 339        toplevel \
 340        labelframe \
 341        ttk:frame \
 342        ttk:toplevel \
 343        ttk:labelframe \
 344     ]
 345
 346 namespace eval ::itcl::builtin::Info {
 347
 348 proc hulltypes {args} {
 349     namespace upvar ::itcl::internal::dicts hullTypes hullTypes
 350
 351     set numArgs [llength $args]
 352     if {$numArgs > 1} {
 353         error "wrong # args should be: info hulltypes ?<pattern>?"
 354     }
 355     set pattern ""
 356     if {$numArgs > 0} {
 357         set pattern [lindex $args 0]
 358     }
 359     if {$pattern ne ""} {
 360         return [lsearch -all -inline -glob $hullTypes $pattern]
 361     }
 362     return $hullTypes
 363
 364 }
 365
 366 proc widgetclasses {args} {
 367     set numArgs [llength $args]
 368     if {$numArgs > 1} {
 369         error "wrong # args should be: info widgetclasses ?<pattern>?"
 370     }
 371     set pattern ""
 372     if {$numArgs > 0} {
 373         set pattern [lindex $args 0]
 374     }
 375     set myDict [set ::itcl::internal::dicts::classes]
 376     if {![dict exists $myDict widget]} {
 377         return [list]
 378     }
 379     set myDict [dict get $myDict widget]
 380     set result [list]
 381     if {$pattern ne ""} {
 382         foreach key [dict keys $myDict] {
 383             set myInfo [dict get $myDict $key]
 384             set value [dict get $myInfo -widget]
 385             if {[string match $pattern $value]} {
 386                 lappend result $value
 387             }
 388         }
 389     } else {
 390         foreach key [dict keys $myDict] {
 391             set myInfo [dict get $myDict $key]
 392             lappend result [dict get $myInfo -widget]
 393         }
 394     }
 395     return $result
 396 }
 397
 398 proc widgets {args} {
 399     set numArgs [llength $args]
 400     if {$numArgs > 1} {
 401         error "wrong # args should be: info widgets ?<pattern>?"
 402     }
 403     set pattern ""
 404     if {$numArgs > 0} {
 405         set pattern [lindex $args 0]
 406     }
 407     set myDict [set ::itcl::internal::dicts::classes]
 408     if {![dict exists $myDict widget]} {
 409         return [list]
 410     }
 411     set myDict [dict get $myDict widget]
 412     set result [list]
 413     if {$pattern ne ""} {
 414         foreach key [dict keys $myDict] {
 415             set myInfo [dict get $myDict $key]
 416             set value [dict get $myInfo -name]
 417             if {[string match $pattern $value]} {
 418                 lappend result $value
 419             }
 420         }
 421     } else {
 422         foreach key [dict keys $myDict] {
 423             set myInfo [dict get $myDict $key]
 424             lappend result [dict get $myInfo -name]
 425         }
 426     }
 427     return $result
 428 }
 429
 430 proc widgetadaptors {args} {
 431     set numArgs [llength $args]
 432     if {$numArgs > 1} {
 433         error "wrong # args should be: info widgetadaptors ?<pattern>?"
 434     }
 435     set pattern ""
 436     if {$numArgs > 0} {
 437         set pattern [lindex $args 0]
 438     }
 439     set myDict [set ::itcl::internal::dicts::classes]
 440     if {![dict exists $myDict widgetadaptor]} {
 441         return [list]
 442     }
 443     set myDict [dict get $myDict widgetadaptor]
 444     set result [list]
 445     if {$pattern ne ""} {
 446         foreach key [dict keys $myDict] {
 447             set myInfo [dict get $myDict $key]
 448             set value [dict get $myInfo -name]
 449             if {[string match $pattern $value]} {
 450                 lappend result $value
 451             }
 452         }
 453     } else {
 454         foreach key [dict keys $myDict] {
 455             set myInfo [dict get $myDict $key]
 456             lappend result [dict get $myInfo -name]
 457         }
 458     }
 459     return $result
 460 }
 461
 462 } ; # end ::itcl::builtin::Info