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:''
   * [Ensemble]
   * [subcommands]
   * [SubCommands and named arguments]
----
[Category Command]