448 lines
12 KiB
Tcl
448 lines
12 KiB
Tcl
#
|
|
# 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
|