First of all, you create a group of options (with ::args::init). Each group contains a set of classes, and each class has one or more options associated with it. Each class has a default value, and a setting which tells it whether the args associated with that class take a value, or are simply booleans (set/not set).
::args::init $group class1 options1 hasArg1 default1 ?classN optionsN hasArgN defaultN?$group is the name of an array which will be created, which holds information about this group of options. class1 is the name of the class. options1 is a Tcl list of the options associated with this class. ''hasArg1' should be either 1 (the options take an argument) or 0 (they do not). default1 is the default value - if the options take an argument (ie, hasArg1 is 1), this can be any string. If hasArg1 is 0, it should be 1 or 0, and will default to that value when the option is not given (and be set to the opposite when it is given). For example,
::args::init myWidget Foreground [list -foreground -fg] 1 black Background [list -background -bg] 1 white \
Foobar -foobar 0 0creates an array, $myWidget, holding info about several options: the -foreground and -fg options refer to the same value, which defaults to "black". The -background and -bg options refer to another value, this one defaulting to white. And the -foobar option (which takes no arg, and is a boolean) refers to another value, and defaults to 0, but will be set to 1 if the -foobar option is set.You would create a group for, for example, every type of widget you have, in this case the "myWidget" widget.When you've created a group, you must then create an instance of the group. You would create an instance of the "myWidget" object set every time a "myWidget" widget is created:
::args::instance $instance $prefix $group$instance refers to an array which will hold information about this instance. All vars created in the array will begin with the $prefix prefix, which allows you to use one array to store info on all instances of a particular group. For instance, if a "myWidget" widget named .bar was created, you might use:
% ::args::instance myWidgetOptions .bar, myWidgetto set the default options for it.
After an instance has been created, you can edit it at any time using the setopts command:
::args::setopts $instance $prefix argsIt uses an $instance and $prefix the same as the "instance" command. args is a list of arguments to set. For instance:
% ::args::setopts myWidgetOptions .bar, -fg red -background "sky blue"would edit the Foreground and Background options. This would be the backend to .bar configure $args
You can also query the options at any time, using the "query" comand. Again, it takes an $instance and $prefix from the "instance" command, along with an argument to query:
% ::args::query $instance $prefix option fullIf full is 0 (default), the current value of the option option is returned. Otherwise, a Tcl list containing the option name, it's class, it's default value and it's current value is returned. This is the difference between $widget cget -option and $widget configure -option in most Tk widgets.
% ::args::query myWidgetOptions .bar, -fg red % ::args::query myWidgetOptions .bar, -fg 1 -fg Foreground black red
And finally, the code itself:
namespace eval ::args {}
proc ::args::init {_group args} {
upvar 1 $_group group
foreach {class options hasarg default} $args {
foreach x $options {
set group(opt,$x) $class
}
if { $hasarg != "0" && $hasarg != "1" } {
return -code error "invalid 'hasarg' \"$hasarg\"";
}
set group(hasarg,$class) $hasarg
if { $hasarg == "0" } {
set default [expr {$default ? "1" : "0"}]
}
set group(val,$class) $default
}
};# init
proc ::args::instance {_inst prefix _group} {
upvar 1 $_inst inst $_group group
set inst(${prefix}group) $_group
foreach x [array names group val,*] {
set inst($prefix$x) $group($x)
}
};# instance
proc ::args::setopts {_inst prefix args} {
upvar 1 $_inst inst
upvar 1 $inst(${prefix}group) group
while { [llength $args] } {
set this [lindex $args 0]
if { ![info exists group(opt,$this)] } {
return -code error "unknown option \"$this\"";
}
set args [lrange $args 1 end]
set class $group(opt,$this)
if { $group(hasarg,$class) == "0" } {
set inst(${prefix}val,$class) [expr {!$group(val,$class)}]
} else {
if { [llength $args] > 0 } {
set val [lindex $args 0]
set args [lrange $args 1 end]
set inst(${prefix}val,$class) $val
} else {
return -code error "no argument specified for \"$this\""
}
}
}
};# setopts
proc ::args::query {_inst prefix this {full 0}} {
upvar 1 $_inst inst
upvar 1 $inst(${prefix}group) group
if { ![info exists group(opt,$this)] } {
return -code error "unknown option \"$this\"";
}
set class $group(opt,$this)
if { $full } {
return [list $this $class $group(val,$class) $inst(${prefix}val,$class)];
} else {
return $inst(${prefix}val,$class);
}
};# queryAny comments, questions, criticisms, etc, are welcomed.
See also: Named Arguments
