Version 0 of TclOO and configure

Updated 2017-12-05 22:36:21 by dkf

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]
            }
        }

        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]
                        }
                }
        }

        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
                }
        }

        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
        }
    }
}