subproc

by slebetman:

Procs with subcommands are very common in Tcl and Tk. A good example is the string command which rolls all string operations into a single proc. I personally like this style of programming (though it may be verbose at times) so I've written the following helper proc to construct such procs-with-subcommands:

SYNOPSIS:

: subproc name ?init? body

DESCRIPTION:

The subproc command creates a new tcl procedure named name just like a proc command would. The body of the subproc command contains subcommands of the newly created procedure. If init is specified its contents will be evaluated before the specified subcommand in the same context as the subcommand. The subcommands are defined in the format:

: subcommand_name args body

The format of subcommands are similar to the arguments of the proc command. If the subcommand_name is default then its body is evaluated if no other subcommands matches the invoked command. The parameter args is a list of parameters to pass to the specified subcommand. Just like a proc, if the last argument is args then all remaining parameters are passed as a single list. Unlike a proc however, the list of parameters args does not support default values.

IMPLEMENTATION:

It's quite ugly but it works:

    proc subproc {name args} {
      # Process the optional initial body code:
      if {[llength $args] == 2} {
        set body [lindex $args 0]
        set args [lindex $args 1]
      } else {
        set args [lindex $args 0]
      }
      
      # Strip comments from the subproc body so that we can
      # support comments in between subprocs:
      set procs ""
      foreach x [split $args "\n"] {
        if {[string index [string trim $x] 0] != "#"} {
          append procs "$x\n"
        }
      }
      
      # Construct the proc:
      append body "\nset op \[lindex \$args 0\]\n"
      append body "set args \[lrange \$args 1 end\]\n"
      append body "switch -exact \$op \{\n"
      foreach {op params script} $procs {
        if {$op != "default"} {
          append body "{$op} \{\n"
        } else {
          append body "default \{\n"
        }
        set paramLength [llength $params]
        if {[lindex $params end] == "args"} {
          append body "if {\[llength \$args\] < [expr $paramLength-1]} "
        } else {
          append body "if {\[llength \$args\] != $paramLength} "
        }
        append body "{error {wrong # args: should be \"$name $op $params\"}}\n"
        for {set i 0} {$i < $paramLength} {incr i} {
          set par [lindex $params $i]
          if {$par == "args"} {
            append body "set {$par} \[lrange \$args $i end\]\n"
          } else {
            append body "set {$par} \[lindex \$args $i\]\n"
          }
        }
        append body "$script\}\n"
      }
      append body "\}\n"
      proc $name {args} $body
    }

EXAMPLES:

Defining a subproc is easy and defining the body of subcommands work just like writing a regular proc:

    subproc listOp {

      # Returns the list element at idx.
      index {L idx} {
        return [lindex $L $idx]
      }

      # Silly code to dump the list.
      dump {L} {
        foreach x $L {
          if {[listOp length $x] == 1} {
            puts $x
          } else {
            foreach y $x {
              puts "  $y"
            }
          }
        }
      }

      # Returns elements in the list from start to end.
      range {L start end} {
        return [lrange $L $start $end]
      }

      # Returns the number of elements in the list.
      length {L} {
        return [llength $L]
      }
    }

Now you can use the proc listOp:

    % set test [list This is "very cool"]
    This is {very cool}
    % listOp length $test
    3
    % listOp dump $test
    This
    is
      very
      cool

The following example illustrates the use of the default subcommand and using args in the subcommand definition:

    subproc config {
      # Init code for all subcommands:
      global configArray
      } {

      # Initialise config array with defaults:
      init {} {
        array set configArray {
          cfg1 1
          cfg2 "two"
        }
        return
      }

      # Get configuration:
      get {args} {
        set ret ""
        foreach x $args {
          lappend ret $configArray($x)
        }
        return $ret
      }

      # Set configuration
      # Generate error if configuration item doesn't exist:
      set {args} {
        foreach {key val} $args {
          set configArray($key)
          set configArray($key) $val
        }
        return
      }

      # If called without any subcommand, dump configs:
      default {} {
        return [array get configArray]
      }
    }

    % config init
    % config set cfg1 100
    % puts [config get cfg1]
    100
    % config set cfg1 100 cfg2 200
    % puts [config]
    cfg1 100 cfg2 200

See also edit