Named Arguments (MG)

MG Sep 29th 2005 - Below is a set of 4 procs for working with named arguments, probably of more use for widgets (or megawidgets) than it is with doing named args for other procs. (Please note the "technical terms" here are made up, so if there actually are proper ones, please let me know:)

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 0

creates 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, myWidget

to 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 args

It 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 full

If 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);
      }
 };# query

Any comments, questions, criticisms, etc, are welcomed.