Wanted a way to add a few pieces of information and commands to a widget. Instead of any complicated class structure or anything like that just call the widget differently.
text .txt
wid .txt -background blue ; # does that same thing as ".txt -background blue"
wid_addInfo .txt -seeme SeeME ""
puts [wid .txt configure -seeme] ; # outputs "SeeME"
proc asubcmd {args} { puts [info level [info level]] }
wid_addSubCmd .txt mysubcmd asubcmd
wid .txt mysubcmd ; # outputs "asubcmd .txt"
namespace eval ::WidInfo {
# widInfo(<widName>,option,<optionName>) {<optionName> {} {} <defaultValue> <value>}
# widInfo(<widName>,subcmd,<subcmd>) <cmdAndArgs>
# widInfo(<widName>,nativeSubcmds) { subcmd1 subcmd2 ...}
# widInfo(<widName>,nativeOptions) { option1 option2 ...}
proc optionExists {widName optionName} { ; # does the option exists
variable widInfo
set ret [info exists widInfo([set widName],option,[set optionName])]
if {! $ret} {
error "unknown option \"-${optionName}\""
}
return $ret
}
proc getWidgetOptions {widName} {
variable widInfo
set val [$widName configure]
set options {}
foreach v $val {
lappend options [lindex $v 0]
}
set widInfo([set widName],nativeOptions) $options
}
proc isNativeWidgetOption {widName optionName} {
variable widInfo
return [expr [lsearch $widInfo([set widName],nativeOptions) $optionName] != -1]
}
# operations on Wid optionFullValue
proc getWidConfigureInfo {widName} { ; # get all the WidInfo configure information
variable widInfo
set ret {}
foreach n [array names widInfo $widName,option,*] {
lappend ret $widInfo([set n])
}
return $ret
}
# operations on optionFullValue
proc setWidConfigureValue {widName optionName optionFullValue} { ; # set a WidInfo option
variable widInfo
set widInfo([set widName],option,[set optionName]) $optionFullValue
}
proc getWidConfigureOptionInfo {widName optionName} {
variable widInfo
optionExists $widName $optionName ; # exception on fail
return $widInfo([set widName],option,[set optionName])
}
# operations on defaultValue
proc getWidConfigureValueDefault {widName optionName} {
variable widInfo
optionExists $widName $optionName ; # exception on fail
return [lindex [getWidConfigureOptionInfo $widName $optionName] end-1]
}
proc setWidConfigureValueDefault {widName optionName defaultValue} {
variable widInfo
optionExists $widName $optionName ; # exception on fail
set optionFullValue [getWidConfigureOptionInfo $widName $optionName]
set optionFullValue [lreplace $optionFullValue end-1 end-1 $defaultValue]
setWidConfigureValue $widName $optionName $optionFullValue
}
# operations on value
proc getWidConfigureValueValue {widName optionName} {
variable widInfo
optionExists $widName $optionName ; # exception on fail
return [lindex [getWidConfigureOptionInfo $widName $optionName] end]
}
proc setWidConfigureValueValue {widName optionName value} {
variable widInfo
optionExists $widName $optionName ; # exception on fail
set default [getWidConfigureValueDefault $widName $optionName]
setWidConfigureValue $widName $optionName [list $optionName {} {} $default $value]
}
# TODO avoid name configure in options
# operations on full Wid and widget
proc configure_0_args {widName} {
variable widInfo
return [concat [$widName configure] [getWidConfigureInfo $widName]]
}
proc configure_1_args {widName option} {
variable widInfo
if {![catch {optionExists $widName $option}]} {
return [getWidConfigureOptionInfo $widName $option]
}
return [$widName configure $option]
}
proc configure_2n_args {widName arglist} {
foreach {n v} $arglist {
if { [catch { optionExists $widName $n } ] } {
$widName configure $n $v
} else {
setWidConfigureValueValue $widName $n $v
}
}
}
proc cget {widName optionName} {
if {[catch {optionExists $widName $optionName}]} {
return [$widName cget $optionName]
}
return [getWidConfigureValueValue $widName $optionName]
}
# public interface to specialize options
proc wid_addInfo {widName name value defaultValue} { ; # public interface to add info to wid
variable widInfo
setWidConfigureValue $widName $name [list $name {} {} $defaultValue $value]
}
# public interface to specialize subcommand
proc wid_addSubcmd {widName name procAndArgs} {
variable widInfo
# widInfo(<widName>,subcmd,<subcmd>) <cmdAndArgs>
set widInfo([set widName],subcmd,[set name]) $procAndArgs
}
namespace export wid_addSubcmd
proc wid_subCmds {widName} {
variable widInfo
set ret {}
foreach n [array names widInfo ${widName},subcmd,*] {
lappend ret [lrange [split $n ,] end]
}
return $ret
}
proc wid_addSubCmd {widName name cmdAndArgs} {
variable widInfo
set widInfo([set widName],subcmd,[set name]) $cmdAndArgs
}
namespace export wid_addSubCmd
proc wid_hasSubCmd {widName cmd} {
variable widInfo
return [info exists widInfo([set widName],subcmd,[set cmd])]
}
proc native_hasSubCmd {widName cmd} {
variable widInfo
return [expr [lsearch $widInfo([set widName],nativeSubcmds) $cmd] != -1]
}
proc unknownSubCmd_error {widName subcmd} {
variable widInfo
if {![wid_hasSubCmd $widName $subcmd] && ![native_hasSubCmd $widName $subcmd]} {
error "bad option \"${subcmd}\": must be [join $widName([set widName],nativeSubcmds) {, }], [join [wid_subCmds $widName]] {, }]"
}
}
proc getWidgetSubCmds widName {
variable widInfo
catch { $widName tomrom } output
regsub {bad option "[^"]+": must be } $output "" output
regsub {, or} $output "" output
regsub -all {,} $output "" output
set widInfo([set widName],nativeSubcmds) $output
}
proc wid_executeSubCmd {widName name args} {
variable widInfo
set cmd $widInfo([set widName],subcmd,[set name])
puts "[info level [info level ]] == $cmd"
{*}$cmd {*}$args $widName
}
proc executeSubCmd {widName name args} {
if {[wid_hasSubCmd $widName $name]} {
return [wid_executeSubCmd $widName $name {*}$args]
}
return [$widName $name {*}$args]
}
proc wid {widName args} {
variable widInfo
if {![info exists widInfo([set widName],nativeSubcmds)]} {
getWidgetSubCmds $widName
getWidgetOptions $widName
}
set n [llength $args]
set op [lindex $args 0]
if {$op ne "configure" && $op ne "cget"} {
if {[wid_hasSubCmd $widName $op]} {
return [executeSubCmd $widName $op {*}[lrange $args 1 end]]
} elseif {[native_hasSubCmd $widName $op]} {
return [$widName {*}$args]
}
}
if {$n == 1} {
# widName configure
if {$op eq "configure"} {
return [configure_0_args $widName]
}
} elseif {$n == 2} {
# widName configure -background
# widName cget -background
if {$op eq "configure"} {
return [configure_1_args $widName [lindex $args 1]]
} elseif {$op eq "cget"} {
return [cget $widName [lindex $args 1]]
}
} elseif {$n >= 3} {
if {$op eq "configure"} { ; # widName configure -option value
return [configure_2n_args $widName [lrange $args 1 end]]
}
}
$widName {*}$args
}
namespace export wid
} ; # end ns WidInfo
