summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.3/itclWidget.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.3/itclWidget.tcl')
-rw-r--r--systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.3/itclWidget.tcl447
1 files changed, 447 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.3/itclWidget.tcl b/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.3/itclWidget.tcl
new file mode 100644
index 0000000000..5fcda510e0
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.3/itclWidget.tcl
@@ -0,0 +1,447 @@
+#
+# itclWidget.tcl
+# ----------------------------------------------------------------------
+# Invoked automatically upon startup to customize the interpreter
+# for [incr Tcl] when one of ::itcl::widget or ::itcl::widgetadaptor 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
+# package require itclwidget [set ::itcl::version]
+
+namespace eval ::itcl {
+
+proc widget {name args} {
+ set result [uplevel 1 ::itcl::internal::commands::genericclass widget $name $args]
+ # we handle create by owerselfs !! allow classunknown to handle that
+ oo::objdefine $result unexport create
+ return $result
+}
+
+proc widgetadaptor {name args} {
+ set result [uplevel 1 ::itcl::internal::commands::genericclass widgetadaptor $name $args]
+ # we handle create by owerselfs !! allow classunknown to handle that
+ oo::objdefine $result unexport create
+ return $result
+}
+
+} ; # end ::itcl
+
+
+namespace eval ::itcl::internal::commands {
+
+proc initWidgetOptions {varNsName widgetName className} {
+ set myDict [set ::itcl::internal::dicts::classOptions]
+ if {$myDict eq ""} {
+ return
+ }
+ if {![dict exists $myDict $className]} {
+ return
+ }
+ set myDict [dict get $myDict $className]
+ foreach option [dict keys $myDict] {
+ set infos [dict get $myDict $option]
+ set resource [dict get $infos -resource]
+ set class [dict get $infos -class]
+ set value [::option get $widgetName $resource $class]
+ if {$value eq ""} {
+ if {[dict exists $infos -default]} {
+ set defaultValue [dict get $infos -default]
+ uplevel 1 set ${varNsName}::itcl_options($option) $defaultValue
+ }
+ } else {
+ uplevel 1 set ${varNsName}::itcl_options($option) $value
+ }
+ }
+}
+
+proc initWidgetDelegatedOptions {varNsName widgetName className args} {
+ set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
+ if {$myDict eq ""} {
+ return
+ }
+ if {![dict exists $myDict $className]} {
+ return
+ }
+ set myDict [dict get $myDict $className]
+ foreach option [dict keys $myDict] {
+ set infos [dict get $myDict $option]
+ if {![dict exists $infos -resource]} {
+ # this is the case when delegating "*"
+ continue
+ }
+ if {![dict exists $infos -component]} {
+ # nothing to do
+ continue
+ }
+ # check if not in the command line options
+ # these have higher priority
+ set myOption $option
+ if {[dict exists $infos -as]} {
+ set myOption [dict get $infos -as]
+ }
+ set noOptionSet 0
+ foreach {optName optVal} $args {
+ if {$optName eq $myOption} {
+ set noOptionSet 1
+ break
+ }
+ }
+ if {$noOptionSet} {
+ continue
+ }
+ set resource [dict get $infos -resource]
+ set class [dict get $infos -class]
+ set component [dict get $infos -component]
+ set value [::option get $widgetName $resource $class]
+ if {$component ne ""} {
+ if {$value ne ""} {
+ set compVar [namespace eval ${varNsName}${className} "set $component"]
+ if {$compVar ne ""} {
+ uplevel 1 $compVar configure $myOption $value
+ }
+ }
+ }
+ }
+}
+
+proc widgetinitobjectoptions {varNsName widgetName className} {
+#puts stderr "initWidgetObjectOptions!$varNsName!$widgetName!$className!"
+}
+
+proc deletehull {newName oldName what} {
+ if {$what eq "delete"} {
+ set name [namespace tail $newName]
+ regsub {hull[0-9]+} $name {} name
+ rename $name {}
+ }
+ if {$what eq "rename"} {
+ set name [namespace tail $newName]
+ regsub {hull[0-9]+} $name {} name
+ rename $name {}
+ }
+}
+
+proc hullandoptionsinstall {objectName className widgetClass hulltype args} {
+ if {$hulltype eq ""} {
+ set hulltype frame
+ }
+ set idx 0
+ set found 0
+ foreach {optName optValue} $args {
+ if {$optName eq "-class"} {
+ set found 1
+ set widgetClass $optValue
+ break
+ }
+ incr idx
+ }
+ if {$found} {
+ set args [lreplace $args $idx [expr {$idx + 1}]]
+ }
+ if {$widgetClass eq ""} {
+ set widgetClass $className
+ set widgetClass [string totitle $widgetClass]
+ }
+ set cmd "set win $objectName; ::itcl::builtin::installhull using $hulltype -class $widgetClass $args"
+ uplevel 2 $cmd
+}
+
+} ; # end ::itcl::internal::commands
+
+namespace eval ::itcl::builtin {
+
+proc installhull {args} {
+ set cmdPath ::itcl::internal::commands
+ set className [uplevel 1 info class]
+
+ set replace 0
+ switch -- [llength $args] {
+ 0 {
+ return -code error\
+ "wrong # args: should be \"[lindex [info level 0] 0]\
+ name|using <widgetType> ?arg ...?\""
+ }
+ 1 {
+ set widgetName [lindex $args 0]
+ set varNsName $::itcl::internal::varNsName($widgetName)
+ }
+ default {
+ upvar win win
+ set widgetName $win
+
+ set varNsName $::itcl::internal::varNsName($widgetName)
+ set widgetType [lindex $args 1]
+ incr replace
+ if {[llength $args] > 3 && [lindex $args 2] eq "-class"} {
+ set classNam [lindex $args 3]
+ incr replace 2
+ } else {
+ set classNam [string totitle $widgetType]
+ }
+ uplevel 1 [lreplace $args 0 $replace $widgetType $widgetName -class $classNam]
+ uplevel 1 [list ${cmdPath}::initWidgetOptions $varNsName $widgetName $className]
+ }
+ }
+
+ # initialize the itcl_hull variable
+ set i 0
+ set nam ::itcl::internal::widgets::hull
+ while {1} {
+ incr i
+ set hullNam ${nam}${i}$widgetName
+ if {[::info command $hullNam] eq ""} {
+ break
+ }
+ }
+ uplevel 1 [list ${cmdPath}::sethullwindowname $widgetName]
+ uplevel 1 [list ::rename $widgetName $hullNam]
+ uplevel 1 [list ::trace add command $hullNam {delete rename} ::itcl::internal::commands::deletehull]
+ catch {${cmdPath}::checksetitclhull [list] 0}
+ namespace eval ${varNsName}${className} "set itcl_hull $hullNam"
+ catch {${cmdPath}::checksetitclhull [list] 2}
+ uplevel 1 [lreplace $args 0 $replace ${cmdPath}::initWidgetDelegatedOptions $varNsName $widgetName $className]
+}
+
+proc installcomponent {args} {
+ upvar win win
+
+ set className [uplevel 1 info class]
+ set myType [${className}::info types [namespace tail $className]]
+ set isType 0
+ if {$myType ne ""} {
+ set isType 1
+ }
+ set numArgs [llength $args]
+ set usage "usage: installcomponent <componentName> using <widgetType> <widgetPath> ?-option value ...?"
+ if {$numArgs < 4} {
+ error $usage
+ }
+ foreach {componentName using widgetType widgetPath} $args break
+ set opts [lrange $args 4 end]
+ if {$using ne "using"} {
+ error $usage
+ }
+ if {!$isType} {
+ set hullExists [uplevel 1 ::info exists itcl_hull]
+ if {!$hullExists} {
+ error "cannot install \"$componentName\" before \"itcl_hull\" exists"
+ }
+ set hullVal [uplevel 1 set itcl_hull]
+ if {$hullVal eq ""} {
+ error "cannot install \"$componentName\" before \"itcl_hull\" exists"
+ }
+ }
+ # check for delegated option and ask the option database for the values
+ # first check for number of delegated options
+ set numOpts 0
+ set starOption 0
+ set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
+ if {[dict exists $myDict $className]} {
+ set myDict [dict get $myDict $className]
+ foreach option [dict keys $myDict] {
+ if {$option eq "*"} {
+ set starOption 1
+ }
+ incr numOpts
+ }
+ }
+ set myOptionDict [set ::itcl::internal::dicts::classOptions]
+ if {[dict exists $myOptionDict $className]} {
+ set myOptionDict [dict get $myOptionDict $className]
+ }
+ set cmd [list $widgetPath configure]
+ set cmd1 "set $componentName \[$widgetType $widgetPath\]"
+ uplevel 1 $cmd1
+ if {$starOption} {
+ upvar $componentName compName
+ set cmd1 [list $compName configure]
+ set configInfos [uplevel 1 $cmd1]
+ foreach entry $configInfos {
+ if {[llength $entry] > 2} {
+ foreach {optName resource class defaultValue} $entry break
+ set val ""
+ catch {
+ set val [::option get $win $resource $class]
+ }
+ if {$val ne ""} {
+ set addOpt 1
+ if {[dict exists $myDict $$optName]} {
+ set addOpt 0
+ } else {
+ set starDict [dict get $myDict "*"]
+ if {[dict exists $starDict -except]} {
+ set exceptions [dict get $starDict -except]
+ if {[lsearch $exceptions $optName] >= 0} {
+ set addOpt 0
+ }
+
+ }
+ if {[dict exists $myOptionDict $optName]} {
+ set addOpt 0
+ }
+ }
+ if {$addOpt} {
+ lappend cmd $optName $val
+ }
+
+ }
+
+ }
+ }
+ } else {
+ foreach optName [dict keys $myDict] {
+ set optInfos [dict get $myDict $optName]
+ set resource [dict get $optInfos -resource]
+ set class [namespace tail $className]
+ set class [string totitle $class]
+ set val ""
+ catch {
+ set val [::option get $win $resource $class]
+ }
+ if {$val ne ""} {
+ if {[dict exists $optInfos -as] } {
+ set optName [dict get $optInfos -as]
+ }
+ lappend cmd $optName $val
+ }
+ }
+ }
+ lappend cmd {*}$opts
+ uplevel 1 $cmd
+}
+
+} ; # end ::itcl::builtin
+
+set ::itcl::internal::dicts::hullTypes [list \
+ frame \
+ toplevel \
+ labelframe \
+ ttk:frame \
+ ttk:toplevel \
+ ttk:labelframe \
+ ]
+
+namespace eval ::itcl::builtin::Info {
+
+proc hulltypes {args} {
+ namespace upvar ::itcl::internal::dicts hullTypes hullTypes
+
+ set numArgs [llength $args]
+ if {$numArgs > 1} {
+ error "wrong # args should be: info hulltypes ?<pattern>?"
+ }
+ set pattern ""
+ if {$numArgs > 0} {
+ set pattern [lindex $args 0]
+ }
+ if {$pattern ne ""} {
+ return [lsearch -all -inline -glob $hullTypes $pattern]
+ }
+ return $hullTypes
+
+}
+
+proc widgetclasses {args} {
+ set numArgs [llength $args]
+ if {$numArgs > 1} {
+ error "wrong # args should be: info widgetclasses ?<pattern>?"
+ }
+ set pattern ""
+ if {$numArgs > 0} {
+ set pattern [lindex $args 0]
+ }
+ set myDict [set ::itcl::internal::dicts::classes]
+ if {![dict exists $myDict widget]} {
+ return [list]
+ }
+ set myDict [dict get $myDict widget]
+ set result [list]
+ if {$pattern ne ""} {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ set value [dict get $myInfo -widget]
+ if {[string match $pattern $value]} {
+ lappend result $value
+ }
+ }
+ } else {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ lappend result [dict get $myInfo -widget]
+ }
+ }
+ return $result
+}
+
+proc widgets {args} {
+ set numArgs [llength $args]
+ if {$numArgs > 1} {
+ error "wrong # args should be: info widgets ?<pattern>?"
+ }
+ set pattern ""
+ if {$numArgs > 0} {
+ set pattern [lindex $args 0]
+ }
+ set myDict [set ::itcl::internal::dicts::classes]
+ if {![dict exists $myDict widget]} {
+ return [list]
+ }
+ set myDict [dict get $myDict widget]
+ set result [list]
+ if {$pattern ne ""} {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ set value [dict get $myInfo -name]
+ if {[string match $pattern $value]} {
+ lappend result $value
+ }
+ }
+ } else {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ lappend result [dict get $myInfo -name]
+ }
+ }
+ return $result
+}
+
+proc widgetadaptors {args} {
+ set numArgs [llength $args]
+ if {$numArgs > 1} {
+ error "wrong # args should be: info widgetadaptors ?<pattern>?"
+ }
+ set pattern ""
+ if {$numArgs > 0} {
+ set pattern [lindex $args 0]
+ }
+ set myDict [set ::itcl::internal::dicts::classes]
+ if {![dict exists $myDict widgetadaptor]} {
+ return [list]
+ }
+ set myDict [dict get $myDict widgetadaptor]
+ set result [list]
+ if {$pattern ne ""} {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ set value [dict get $myInfo -name]
+ if {[string match $pattern $value]} {
+ lappend result $value
+ }
+ }
+ } else {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ lappend result [dict get $myInfo -name]
+ }
+ }
+ return $result
+}
+
+} ; # end ::itcl::builtin::Info