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

======

<<categories>>Enter Category Here