TclOO and configure

Here's some code I've been working on to try to do a Tk-like configure and cget using TclOO. (You might want to look at how option works to understand a few bits of this code.)

oo::class create Configurable {
    # Returns a SORTED DICTIONARY. Keys are full option names. Values are 4-element lists:
    #     1. backing instance variable name
    #     2. Tk option DB info (two elements, name and class; name begins with lower case, class with upper)
    #     3. main default value; assumed to be valid
    #     4. validator callback, or empty for no validation
    method ConfigDescriptor {} {
        throw {TKOO MEGA NO_CONFIG} "no configuration descriptor defined"
    }

    method GetDefault {widget itemdescriptor} {
        lassign $itemdescriptor varname optionDBinfo default validator
        # This is the ONLY truly Tk-specific code in here
        if {[winfo exists $widget] && $optionDBinfo ne "{} {}"} {
            return [list [option get $widget {*}$optionDBinfo] $default]
        } else {
            return [list $default]
        }
    }

    # Sets up defaults; intended for use in a constructor
    method SetInitValues {widget} {
        set descriptor [my ConfigDescriptor]
        dict for {option desc} $descriptor {
            lassign $desc varname optionDBinfo default validator
            upvar 0 [my varname $varname] var
            set didset false
            set defaults [my GetDefault $widget $desc]
            foreach default $defaults {
                if {$default ne "" && [llength $validator]} {
                    catch {
                        {*}$validator $option $default
                        set var $default
                        set didset true
                    }
                }
                if {$didset} break
            }
            if {!$didset} {
                set var [lindex $defaults end]
            }
        }
    }

    # A traditional configure; you'll *ALSO* want to call this from a constructor for Tk style
    method configure {args} {
        set descriptor [my ConfigDescriptor]
        if {[llength $args] == 0} {
            set result {}
            dict for {option desc} $descriptor {
                lassign $desc varname optionDBinfo default validator
                upvar 0 [my varname $varname] var
                lappend result [list $option {*}$optionDBinfo $default $var]
            }
            return $result
        } elseif {[llength $args] == 1} {
            set option [lindex $args 0]
            if {[dict exists $descriptor $option]} {
                set desc [dict get $descriptor $option]
            } else {
                set opt [::tcl::prefix match [dict keys $descriptor] $option]
                set desc [dict get $descriptor $opt]
            }
            lassign $desc varname optionDBinfo default validator
            upvar 0 [my varname $varname] var
            return [list $option {*}$optionDBinfo $default $var]
        } elseif {[llength $args] & 1} {
            # Ought to fill this out better
            return -code error "wrong num args..."
        } else {
            foreach {option value} $args {
                if {[dict exists $descriptor $option]} {
                    set desc [dict get $descriptor $option]
                } else {
                    set opt [::tcl::prefix match [dict keys $descriptor] $option]
                    set desc [dict get $descriptor $opt]
                }
                lassign $desc varname optionDBinfo default validator
                upvar 0 [my varname $varname] var
                if {[llength $validator]} {
                    {*}$validator $option $value
                }
                set var $value
            }
            return
        }
    }

    # Traditional cget method
    method cget {option} {
        set descriptor [my ConfigDescriptor]
        if {[dict exists $descriptor $option]} {
            set desc [dict get $descriptor $option]
        } else {
            set opt [::tcl::prefix match [dict keys $descriptor] $option]
            set desc [dict get $descriptor $opt]
        }
        lassign $desc varname optionDBinfo default validator
        upvar 0 [my varname $varname] var
        return $var
    }

    # Sample validator for booleans
    method ValidBoolean {option value} {
        if {![string is boolean -strict $value]} {
            return -code error "bad boolean for $option \"$value\""
        }
    }
}

Example usage:

oo::class create FooBarMegawidget {
    # There are other bits of being a megawidget; I'll not cover them here
    superclass Widget Configurable
    variable cmd enable

    method ConfigDescriptor {} {
        return {
            -command {cmd    {command Command} "" {}}
            -enabled {enable {enabled Enabled} 0 {my ValidBoolean}}
        }
    }

    constructor {widget args} {
        next ...; # Other stuff for setting up
        trace add variable enable write [namespace code {my SetEnable}]
        my SetInitValues $widget
        my configure {*}$args
    }

    method SetEnable args {
        puts "-enabled is now set to $enable"
    }

    method invoke {} {
        if {$cmd ne ""} {
            uplevel "#0" $cmd
        }
    }
}

TclOO

Category Tk