New Megawidget Boilerplate

Haven't posted much to the blog recently. This isn't because things are quiet on the Tcl/Gnocl side, I've just been doing more applications coding. Today's posting is a result of this. I already use a bunch of gnocl megawidgets but there always seems to be slight differences between each module. I thought that I'd settle this once and for all by creatings a boiler plate module which can then be adapted to suit. Because I shift between the gnocl C sources and Tcl, I thought it wise to follow a similar design approach in both.

Individual procedures handle the construction, configuration and command handling for each widget instance and error checking is implemented too.

#---------------
# widget.tcl
#---------------
# Boilerplate object builder package for gnocl derive megawidgets.
# Based upon approach used in Gnocl source code.
# William J Giddings, 28-Mar-14.
#---------------
# Substitute keyword _widget_ for unique object type identifier.
#---------------
# !/bin/sh
# the next line restarts using tclsh \
exec tclsh "$0" "$@"

package require Gnocl
package provide widget

namespace eval _widget_ {}

#---------------
# lists of valid widget options, commands and components
#---------------
#
set _widget_::opts { -text -onClicked -data}
set _widget_::cmds { configure cget type opts cmds}
set _widget_::components {}

#---------------
# implement widget commands
#---------------
#
proc _widget_::cmd {wid cmd args} {

    _widget_::check $cmd

    # apply the commands
    switch -- $cmd {
        opts -
        cmds {return [lsort [set _widget_::$cmd]] }
        type { return "_widget_"}
        configure -
        cget {
            eval "_widget_::$cmd $wid $args"
            }
        default { # shouldn't need to get here, but... }
    }

}

#---------------
# retrieve current component values
#---------------
#
proc _widget_::cget {wid args} {

    # get list of members
    foreach {w id} $_widget_::components {set $w $id}
   
    # obtain current settings
    foreach {a b} $args {
        # apply according to each component
        switch -- $a {
            -onClicked -
            -text { return [$but_1 cget $a] }
            -data { return [$wid cget $a] }
            default { # shouldn't need to get here, but... }
        }
    }
   
}

#---------------
# check options and commands for valid values
#---------------
#
proc _widget_::check { opts } {

    # test for a valid options
    if { [string first - $opts ] >= 0 } {
        foreach {opt val} $opts {
            if { [string first $opt $_widget_::opts] == -1 } {
                set errmsg "[string repeat - 17]\nERROR! Invalid option \"$opt\".\nShould be one of: [lsort $_widget_::opts]\n[string repeat - 17]"
                error $errmsg
            }
        }   
        return
    }
   
    # test for valid command
    foreach {opt } $opts {
    if { [string first $opt $_widget_::cmds] == -1 } {
        set errmsg "[string repeat - 17]\nERROR! Invalid command \"$opt\".\nShould be one of: [lsort $_widget_::cmds]\n[string repeat - 17]"
        error $errmsg
        }
    }

}

#---------------
# configure widget components
#---------------
#
proc _widget_::configure {wid args} {
   
    _widget_::check $args
   
    # recover list of widget components
    foreach {w id} $::_widget_::components {set $w $id}

    # apply new options
    foreach {a b} $args {
        # apply according to each component
        switch -- $a {
            -text -
            -onClicked { $but_1 configure $a $b }
            -data { $wid configure $a $b }
            default { # shouldn't need to get here, but... }
        }
    }
   
}

#---------------
# create and assemble widget components
#---------------
#
proc _widget_::construct {} {
   
    # create object container
    set vbox [gnocl::vBox]

    # create components
    set but_1 [gnocl::button -text BUTTON]

    # assemble components
    $vbox add $but_1

    # add to listing
    set ::_widget_::components [list but_1 $but_1]

    return $vbox
}

#---------------
# the widget command itself
#---------------
#
proc widget {args} {
    set wid [_widget_::construct]

    # configure
    eval "_widget_::configure $wid $args"
   
    # overload the box to add commands
    rename $wid _$wid

    # widget command
    proc $wid {cmd args} {
        set wid [lindex [::info level 0] 0]   
        eval "_widget_::cmd _$wid $cmd $args"          
    }

    return $wid
   
}


proc demo {} {
    set wid(1) [widget -text "HELLO CAMPERS!" -onClicked {puts "HO HI HO!"}]
    gnocl::window -child $wid(1)

    $wid(1) configure -text "HI DI HI" -data "leave my data alone!"
    puts [$wid(1) type]

    catch { $wid(1) configure -a AAA } {}
    catch { $wid(1) nonsuch } {}

    puts [$wid(1) cget -data]

    set wid(2) [widget -text "GOOD MORNING!" -onClicked {puts "GOOD AFTERNOON"} -data BYE-BYE]

    gnocl::window -child $wid(2)
    puts [$wid(2) cget -data]
    puts [$wid(1) opts]
    puts [$wid(2) cmds]

}

demo