CardiacPhase/Git/mingw64/lib/itcl4.1.2/itclWidget.tcl

448 lines
12 KiB
Tcl
Raw Normal View History

2019-05-06 16:34:28 +02:00
#
# 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