dispatch

This is a new control structure that I created an use extensively in my own code. I am posting it because I think it may be useful to other people as well. Please feel free to comment and/or criticize this code.

22Nov02 - Brian Theado - How about a brief description on what is does/what it is good for? I'm pretty slow at reading code and it is taking me longer to figure out what this is than I want to spend. By glancing at the code, it looks similar to the switch statement. Is that the case?

24Nov02 - Joe Mistachkin - Yes, it is similar to a switch statement. The primary way that they differ is that dispatch supports fully "dynamic" cases. Cases can be matched on any valid literals, variables, or commands. Matching can be done in all "standard" modes (exact, glob, regexp, and nocase). In the situation where there may be more than one match, only the first matching case is evaluated. Conforms to all other "standard" switch command behavior. See below for examples.

21Aug03 - Lars H - While examples of making your own control structures are often useful, it looks to me as though this is mostly doing things that the first form of switch (no {} around the list of patterns and bodies, hence one can subject the patterns to all sorts of substitutions) already provides. Or am I overlooking something? The -nocase option can be done with explicit [string tolower], although with variable patterns one might need a lot of these. The -expr option I don't quite understand.

 #
 # Example #1 (variables and commands)
 #

 set case_1 "this"
 set case_2 "that"
 set case_3 "foo"

 set string_to_match "THIS"

 dispatch -exact -nocase -- $string_to_match {
   $case_1 {
     # NOTICE we used a variable for this?
     puts stdout "MATCHED case #1."
   }
   $case_2 {
     # NOTICE we used a variable for this?
     puts stdout "MATCHED case #2."
   }
   $case_3 {
     # NOTICE we used a variable for this?
     puts stdout "MATCHED case #3."
   }
   [string trim $string_to_match] {
     # this case refers to the trimmed version of itself 
     # (the variable being matched), variations on this 
     # could prove quite useful.
     puts stdout "MATCHED trimmed version of self."
   }
   "literal" -
   default {
     # NOTE: the above "literal" case would fall through to this case.
     puts stdout "MATCHED default."
   }
 }

 #
 # Example #2 (use with regexp):
 #

 set email_regexp {^([0-9A-Za-z])([0-9A-Za-z_\.\-]*)@([0-9A-Za-z])([0-9A-Za-z\.\-]*)$}

 set string_to_match "[email protected]"
 
 dispatch -regexp -nocase -- $string_to_match {
   $email_regexp {
     # NOTICE we used a variable for this?
     puts stdout "MATCHED, valid email address."
   }
   default {
     puts stdout "MATCHED default."
   }
 }

Main Source File (dispatch.tcl)

 ###############################################################################
 #
 # Tcl dispatch command
 #
 # Copyright (c) 2001-2003 by Joe Mistachkin.  All rights reserved.
 #
 #  written by: Joe Mistachkin <[email protected]>
 #  created on: 10/07/2001
 # modified on: 08/21/2003
 #
 ###############################################################################
 #
 # The authors hereby grant permission to use, copy, modify, distribute,
 # and license this software and its documentation for any purpose, provided
 # that existing copyright notices are retained in all copies and that this
 # notice is included verbatim in any distributions. No written agreement,
 # license, or royalty fee is required for any of the authorized uses.
 # Modifications to this software may be copyrighted by their authors
 # and need not follow the licensing terms described here, provided that
 # the new terms are clearly indicated on the first page of each file where
 # they apply.
 #
 # IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
 # FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
 # ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
 # DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
 # POSSIBILITY OF SUCH DAMAGE.
 #
 # THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
 # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
 # FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
 # IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
 # NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
 # MODIFICATIONS.
 #
 # GOVERNMENT USE: If you are acquiring this software on behalf of the
 # U.S. government, the Government shall have only "Restricted Rights"
 # in the software and related documentation as defined in the Federal
 # Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2).  If you
 # are acquiring the software on behalf of the Department of Defense, the
 # software shall be classified as "Commercial Computer Software" and the
 # Government shall have only "Restricted Rights" as defined in Clause
 # 252.227-7013 (c) (1) of DFARs.  Notwithstanding the foregoing, the
 # authors grant the U.S. Government and others acting in its behalf
 # permission to use and distribute the software in accordance with the
 # terms specified in this license.
 #
 ###############################################################################
 
 # REQUIRES Tcl 8.0+
 package require "Tcl" "8.0"
 
 # maximum possible number of arguments for dispatch proc
 set dispatch_maximum_arguments "8"
 
 # dispatch error string
 set dispatch_argument_error "wrong # args: should be \"dispatch ?switches? string pattern body ... ?default body?\""
 
 # THESE are ALL the allowed switches for the dispatch proc
 # (except for "--", which is a special case)
 set dispatch_switches [list "-exact" "-nocase" "-expr" "-glob" "-regexp" "-all"]
 
 # dispatch switch error string
 set dispatch_switch_error "bad option, must be one of: $dispatch_switches"
 
 # do not change this
 set dispatch_name "Tcl_dispatch"
 
 # do not change this
 set dispatch_version "2.7"
 
 proc valid_switch { argument variable_name } {
   #
   # check if valid switch (is it in the list?)...
   #
   if {[string index $argument "0"] == "-"} then {
     if {$variable_name != ""} then {
       if {$argument == "--"} then {
         # value 4 means "end of switches"
         # (this is always a valid switch)
         set result "4"
       } else {
         if {(([string index $argument "0"] == "-") && ([string is integer -strict [string range $argument "1" "end"]] != "0"))} then {
           # this is the integer value for use in the future...
           # value 3 means "valid switch"
           set result "3"
         } else {
           upvar "1" $variable_name valid_switches
   
           if {[lsearch $valid_switches $argument] != "-1"} then {
             # value 3 means "valid switch"
             set result "3"
           } else {
             # value 2 means "not a supported switch"
             set result "2"
           }
         }
       }
     } else {
       # value 1 means "invalid variable name" (in this context)
       set result "1"
     }
   } else {
     # value 0 means "not a switch OR not a supported switch"
     set result "0"
   }
 
   return $result
 }
 
 proc check_switch { argument variable_name force } {
   #
   # simply see if passed argument is a supported option
   #
   if {[string index $argument "0"] == "-"} then {
     if {$variable_name != ""} then {
       set switch_name [string range $argument "1" "end"]
 
       # get a handle on the variable (array) that we need to modify
       upvar "1" $variable_name switches
 
       # if always allow or if the switch is actually considered valid...
       if {(($force != "0") || ([info exists switches($switch_name)] != "0"))} then {
         # value 1 means "switch enabled"
         set switches($switch_name) "1"
 
         # value 1 means "processed switch"
         set result "1"
       } else {
         if {[string is integer -strict $argument] != "0"} then {
           # set the integer value for use in the future...
           set switches(value) $argument
 
           # value 1 means "processed switch"
           set result "1"
         } else {
           # value 2 means "invalid switch"
           set result "2"
         }
       }
     } else {
       # value 0 means "did NOT process switch"
       set result "0"
     }
   } else {
     # value 0 means "did NOT process switch"
     set result "0"
   }
 
   return $result
 }
 
 proc dispatch { args } {
   #
   # This is the OUTER dispatch proc.  It handles translation of switches
   # and then forwards the request to dispatch_internal.
   #
   global dispatch_argument_error
   global dispatch_maximum_arguments
   global dispatch_switch_error
   global dispatch_switches
 
   set result ""
 
   # the integer value for use in the future...
   set switches(value) "0"
 
   # all the possible switches...
   set switches(exact) "0"
   set switches(nocase) "0"
   set switches(expr) "0"
   set switches(glob) "0"
   set switches(regexp) "0"
   set switches(all) "0"
   set switches(end) "0"
 
   set count [llength $args]
 
   if {$count <= $dispatch_maximum_arguments} then {
     #
     # this loop is trying to find "the first non-switch argument"...
     #
     set invalid "0"
     set found "0"
     set index "0"
     while {(($index < $count) && ($found == "0") && ($invalid == "0"))} {
       set is_switch [valid_switch [lindex $args $index] dispatch_switches]
 
       switch -exact -- $is_switch {
         "0" {
           #
           # we are done, we found an actual non-switch argument...
           #
           set found "1"
         }
         "1" {
           #
           # invalid...
           #
           set invalid "1"
         }
         "2" {
           #
           # we are done, we found an invalid switch...
           #
           set invalid "1"
         }
         "3" {
           #
           # found a valid switch, process it
           #
           check_switch [lindex $args $index] switches "1"
 
           # skip to next index now
           set index [expr {$index + "1"}]
         }
         "4" {
           #
           # found FINAL switch, process it
           #
           check_switch [lindex $args $index] switches "1"
 
           # skip to next index now
           # next argument, this is still a switch
           set index [expr {$index + "1"}]
 
           set found "1"
         }
         default {
           # we found something invalid...???
           set invalid "1"
         }
       }
     }
 
     if {$found != "0"} then {
       # we must have at least two arguments left...
       if {$index < ($count - "1")} then {
         # what are we dispatching on?
         set dispatch_string [lindex $args $index]
         # advance to the next argument.
         set index [expr {$index + "1"}]
         # this is the body that contains the different possible matches...
         set dispatch_body [lindex $args $index]
         #
         # the magic number "2" in this command is the
         # parameter required for the uplevel commands
         # contained within dispatch_internal
         #
         set result [dispatch_internal $switches(exact) $switches(nocase) $switches(expr) $switches(glob) $switches(regexp) $switches(all) $switches(end) "2" $dispatch_string $dispatch_body]
 
         set dispatch_error "0"
       } else {
         set dispatch_error "1"
       }
     } else {
       if {$invalid != "0"} then {
         set dispatch_error "2"
       } else {
         set dispatch_error "1"
       }
     }
   } else {
     set dispatch_error "1"
   }
 
   switch -exact -- $dispatch_error {
     "1" {
       error $dispatch_argument_error
     }
     "2" {
       error $dispatch_switch_error
     }
   }
 
   return $result
 }
 
 proc dispatch_internal { dispatch_exact dispatch_nocase dispatch_expr dispatch_glob dispatch_regexp dispatch_all dispatch_end dispatch_level dispatch_string dispatch_body } {
   global dispatch_argument_error
   #
   # NOTE: This does NOT function EXACTLY the same as the "switch" command, but it's pretty darn close.
   #
   # 1. ALL of the standard switches for "switch" are supported plus "-nocase".
   # 2. default case can be anywhere (matching STOPS when it is found).
   # 3. string variables ARE supported (the main reason this proc exists).
   # 4. commands are supported for the PATTERNS as well as the script bodies
   #    (must be enclosed in curly braces)...
   #
   # NOTE: Obviously, the length of the dispatch_body argument list must be divisible by 2.
   #
   set result ""
 
   # must have some elements dispatch_body...
   if {[llength $dispatch_body] > "0"} then {
     # must have even number of elements in dispatch_body
     if {[llength $dispatch_body] % "2" == "0"} then {
       #
       # initially, we will return null if nothing matches...
       # same as switch
       #
       set evaluated "0"
       set matched "0"
       foreach {this_pattern this_body} $dispatch_body {
         #
         # make sure we aren't just searching for a proc body
         #
         if {$matched == "0"} then {
           #
           # check if it's the default
           #
           if {$this_pattern == "default"} then {
             # THIS ALWAYS MATCHES, regardless of switches
             # presumably, default is the last one
             set matched "1"
           } else {
             #
             # check if string variable
             #
             if {[string index $this_pattern "0"] == "\$"} then {
               # get variable name portion only
               set variable_name [string range $this_pattern "1" "end"]
 
               # unset in case we set it previously
               # BUGFIX: SQUASH annoying error messages in errorInfo!
               if {[info exists variable_value] != "0"} then {
                 catch {unset variable_value}
               }
               #
               # get variable value from calling proc
               # (could this be done better with upvar?)
               #
               # this needs the [list] command to account for the pathological 
               # case of {this_happy variable_name}.
               #
               set variable_value [uplevel $dispatch_level [list set $variable_name]]
             } else {
               #
               # command, interesting...
               #
               if {[string index $this_pattern "0"] == "\["} then {
                 # get command portion only
                 set variable_name [string range $this_pattern "1" "end-1"]
 
                 # just evaluate the command using uplevel...
                 # [list] is not required here, $variable_name contains a 
                 # complete command in proper form list form.
                 set variable_value [uplevel $dispatch_level $variable_name]
               } else {
                 #
                 # must be some kind of string constant
                 #
                 set variable_value $this_pattern
               }
             }
 
             if {$dispatch_regexp != "0"} then {
               #
               # regexp (for experts only!)
               #
               if {$dispatch_nocase != "0"} then {
                 #
                 # case insensitive specified
                 # check if we matched the value...
                 #
                 if {[regexp -nocase -- $variable_value $dispatch_string] != "0"} then {
                   set matched "1"
                 } else {
                   set matched "0"
                 }
               } else {
                 #
                 # case sensitive is the default
                 # check if we matched the value...
                 #
                 if {[regexp -- $variable_value $dispatch_string] != "0"} then {
                   set matched "1"
                 } else {
                   set matched "0"
                 }
               }
             } else {
               if {$dispatch_glob != "0"} then {
                 #
                 # string match (always a family favorite)
                 #
                 if {$dispatch_nocase != "0"} then {
                   #
                   # case insensitive specified
                   # check if we matched the value...
                   #
                   if {[string match [string tolower $variable_value] [string tolower $dispatch_string]] != "0"} then {
                     set matched "1"
                   } else {
                     set matched "0"
                   }
                 } else {
                   #
                   # case sensitive is the default
                   # check if we matched the value...
                   #
                   if {[string match $variable_value $dispatch_string] != "0"} then {
                     set matched "1"
                   } else {
                     set matched "0"
                   }
                 }
               } else {
                 if {$dispatch_expr != "0"} then {
                   #
                   # NEW: check to see if the truth value of the dispatch arm by itself is non-zero
                   #      (it may have a dynamic value).
                   #
                   if {[expr {int($variable_value)}]} then {
                     set matched "1"
                   } else {
                     set matched "0"
                   }
                 } else {
                   # dispatch_exact is the default
                   if {$dispatch_nocase != "0"} then {
                     #
                     # case insensitive specified
                     # check if we matched the value...
                     #
                     if {[string tolower $dispatch_string] == [string tolower $variable_value]} then {
                       set matched "1"
                     } else {
                       set matched "0"
                     }
                   } else {
                     #
                     # case sensitive is the default
                     # check if we matched the value...
                     #
                     if {$dispatch_string == $variable_value} then {
                       set matched "1"
                     } else {
                       set matched "0"
                     }
                   }
                 }
               }
             }
           }
         }
 
         if {$matched != "0"} then {
           #
           # check for "search for next proc body" like switch does
           #
           if {$this_body == "-"} then {
             #
             # skill skipping to next script body...
             #
             continue
           } else {
             #
             # evaluate this script body (IN THE PROPER LEVEL) and exit loop
             # [list] is not required at this level because the body is a script, not a command.
             #
             set result [uplevel $dispatch_level $this_body]
             set evaluated "1"
             set matched "0"
 
             if {$dispatch_all == "0"} then {
               #
               # if they are NOT allowing multiple (default)
               # break out of loop
               #
               break
             }
           }
         }
       }
 
       set dispatch_error "0"
     } else {
       set dispatch_error "1"
     }
   } else {
     set dispatch_error "1"
   }
 
   if {$dispatch_error != "0"} then {
     error $dispatch_argument_error
   }
 
   return $result
 }
 
 proc dispatch_terminate {} {
   global dispatch_name
   #
   # forget package
   #
   package forget $dispatch_name
 
   #
   # kill vars
   #
   foreach this_global [info globals] {
     if {[string match "dispatch_*" $this_global] != "0"} then {
       # nuke variable in global scope... (dead)
       uplevel "#0" unset $this_global
     }
   }
 
   #
   # kill procs
   #
   rename dispatch ""
   rename dispatch_internal ""
   rename valid_switch ""
   rename check_switch ""
   rename dispatch_terminate ""
 
   return "0"
 }
 
 # loaded OK, provide package
 package provide $dispatch_name $dispatch_version
 
 # // end of file

Tests File (dispatch_sample.tcl)

 ###############################################################################
 #
 # Tcl dispatch command sample and [torture] test suite
 #
 # Copyright (c) 2001-2003 by Joe Mistachkin.  All rights reserved.
 #
 #  written by: Joe Mistachkin <[email protected]>
 #  created on: 10/07/2001
 # modified on: 05/06/2003
 #
 ###############################################################################
 #
 # The authors hereby grant permission to use, copy, modify, distribute,
 # and license this software and its documentation for any purpose, provided
 # that existing copyright notices are retained in all copies and that this
 # notice is included verbatim in any distributions. No written agreement,
 # license, or royalty fee is required for any of the authorized uses.
 # Modifications to this software may be copyrighted by their authors
 # and need not follow the licensing terms described here, provided that
 # the new terms are clearly indicated on the first page of each file where
 # they apply.
 #
 # IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
 # FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
 # ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
 # DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
 # POSSIBILITY OF SUCH DAMAGE.
 #
 # THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
 # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
 # FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
 # IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
 # NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
 # MODIFICATIONS.
 #
 # GOVERNMENT USE: If you are acquiring this software on behalf of the
 # U.S. government, the Government shall have only "Restricted Rights"
 # in the software and related documentation as defined in the Federal
 # Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2).  If you
 # are acquiring the software on behalf of the Department of Defense, the
 # software shall be classified as "Commercial Computer Software" and the
 # Government shall have only "Restricted Rights" as defined in Clause
 # 252.227-7013 (c) (1) of DFARs.  Notwithstanding the foregoing, the
 # authors grant the U.S. Government and others acting in its behalf
 # permission to use and distribute the software in accordance with the
 # terms specified in this license.
 #
 ###############################################################################
 
 # require Tcl 8.0+
 package require Tcl 8.0
 
 # attempt to load dispatch package
 source "dispatch.tcl"
 
 # require dispatch package 2.0+ to be loaded...
 package require Tcl_dispatch 2.0
 
 proc DispatchSample1 { string_to_match } {
   set test_1 "this"
   set test_2 "that"
   set test_3 "foo"
   set test_4 "not used"
   set test_5 "bar"
   set test_6 "FOO"
   set test_7 "BAR"
 
   dispatch $string_to_match {
     $test_1 {
       puts stdout "MATCHED #1\n"
     }
     $test_2 {
       puts stdout "MATCHED #2\n"
     }
     $test_3 {
       puts stdout "MATCHED #3\n"
     }
     "test 4" {
       puts stdout "MATCHED #4\n"
     }
     $test_5 -
     $test_6 -
     $test_7 {
       puts stdout "MATCHED #5,#6,#7\n"
     }
     default {
       puts stdout "MATCHED DEFAULT!\n"
     }
   }
 }
 
 proc DispatchSample2 { string_to_match } {
   set test_1 "this"
   set test_2 "that"
   set test_3 "foo"
   set test_4 "not used"
   set test_5 "bar"
   set test_6 "FOO"
   set test_7 "BAR"
   set test_8 "NOEVAL"
 
   dispatch $string_to_match {
     $test_1 {
       puts stdout "MATCHED #1\n"
     }
     $test_2 {
       puts stdout "MATCHED #2\n"
     }
     $test_3 {
       puts stdout "MATCHED #3\n"
     }
     "test 4" {
       puts stdout "MATCHED #4\n"
     }
     $test_5 -
     $test_6 -
     $test_7 {
       puts stdout "MATCHED #5,#6,#7\n"
     }
     $test_8 -
   }
 }
 
 proc DispatchSample3 { string_to_match } {
 
   dispatch -glob -- $string_to_match {
     "1" {
       puts stdout "MATCHED #1\n"
     }
     "2" {
       puts stdout "MATCHED #2\n"
     }
     "3" {
       error "cannot match #3"
     }
     "*" {
       puts stdout "MATCHED *\n"
     }
   }
 }
 
 proc DispatchSample4 { string_to_match } {
   # MALFORMED dispatch statement test
 
   dispatch $string_to_match {
     "1" {
       puts stdout "MATCHED #1\n"
     }
     "2" {
       puts stdout "MATCHED #2\n"
     }
     "3"
   }
 }
 
 proc DispatchSample5 { string_to_match } {
   set email_regexp {^([0-9A-Za-z])([0-9A-Za-z_\.\-]*)@([0-9A-Za-z])([0-9A-Za-z\.\-]*)$}
 
   dispatch -regexp -nocase -- $string_to_match {
     {^([01]?\d\d?|2[0-4]\d|25[0-5])\.([01]?\d\d?|2[0-4]\d|25[0-5])\.([01]?\d\d?|2[0-4]\d|25[0-5])\.([01]?\d\d?|2[0-4]\d|25[0-5])$} {
       puts stdout "MATCHED, VALID IP\n"
     }
     {^([01]?[0123456789][0123456789]?|2[0-4][0123456789]|25[0-5])\.([01]?[0123456789][0123456789]?|2[0-4][0123456789]|25[0-5])\.([01]?[0123456789][0123456789]?|2[0-4][0123456789]|25[0-5])\.([01]?[0123456789][0123456789]?|2[0-4][0123456789]|25[0-5])$} {
       puts stdout "MATCHED, VALID IP, PRE 8.0\n"
     }
     $email_regexp {
       # NOTICE we used a variable for this?
       puts stdout "MATCHED, VALID EMAIL ADDRESS\n"
     }
     {(<A )(.*?)(HREF=\")(.*?)(\")} {
       puts stdout "MATCHED, VALID HYPERLINK\n"
     }
     default {
       puts stdout "NOT MATCHED REGEXP\n"
     }
   }
 }
 
 proc DispatchSample6 { string_to_match } {
   set sample6_var "this_is_a_test"
 
   dispatch -exact -nocase -- $string_to_match {
     "test" {
       puts stdout "MATCHED TEST\n"
     }
     {[string repeat $sample6_var "2"]} {
       puts stdout "MATCHED TEST * 2\n"
     }
     {\[fakecommand\]} {
       puts stdout "MATCHED FAKE COMMAND\n"
     }
     {[string repeat $sample6_var "3"]} -
     {[string repeat $sample6_var "4"]} {
       puts stdout "MATCHED TEST * 3 OR 4\n"
 
       if {$string_to_match == "this_is_a_testthis_is_a_testthis_is_a_testthis_is_a_test"} then {
         puts stdout "MATCHED TEST * 4\n"
       } else {
         puts stdout "MATCHED TEST * 3\n"
       }
     }
     default {
       puts stdout "NOT MATCHED SAMPLE\n"
     }
   }
 }
 
 proc DispatchSample7 { string_to_match } {
   #
   # default string test
   #
   dispatch $string_to_match {
     "1" {
       puts stdout "MATCHED #1\n"
     }
     "2" {
       puts stdout "MATCHED #2\n"
     }
     "3" {
       puts stdout "MATCHED #3\n"
     }
     "4" {
       puts stdout "MATCHED #4\n"
     }
     "5" {
       puts stdout "MATCHED #5\n"
     }
     "6" {
       puts stdout "MATCHED #6\n"
     }
     "default" {
       puts stdout "MATCHED DEFAULT!\n"
     }
   }
 }
 
 proc DispatchSample8 { string_to_match } {
   #
   # multiple glob test...
   #
   dispatch -glob -all -- $string_to_match {
     "1" {
       puts stdout "MATCHED #1\n"
     }
     "1*" {
       puts stdout "MATCHED GLOB 1*\n"
     }
     "2" {
       puts stdout "MATCHED #2\n"
     }
     "2*" {
       puts stdout "MATCHED GLOB 2*\n"
     }
     "default" {
       puts stdout "MATCHED DEFAULT!\n"
     }
   }
 }
 
 proc DispatchSample9 { string_to_match } {
   #
   # invalid switch test
   #
   dispatch -glob -all -notvalid -- $string_to_match {
     "1" {
       puts stdout "MATCHED #1\n"
     }
     "2" {
       puts stdout "MATCHED #2\n"
     }
     "default" {
       puts stdout "MATCHED DEFAULT!\n"
     }
   }
 }
 
 proc DispatchSample10 { string_to_match } {
   #
   # valid switch-like looking argument after end of switches
   #
   dispatch -glob -- -notvalid {
     "-notvalid" {
       puts stdout "MATCHED -notvalid\n"
     }
     "default" {
       puts stdout "MATCHED DEFAULT!\n"
     }
   }
 }
 
 ###############################################################################
 # series 1, test ``normal`` usage
 ###############################################################################
 puts stdout "TEST #1, should match #1..."
 DispatchSample1 "this"
 puts stdout "TEST #2, should match #2..."
 DispatchSample1 "that"
 puts stdout "TEST #3, should match #3..."
 DispatchSample1 "foo"
 puts stdout "TEST #4, should match #4..."
 DispatchSample1 "test 4"
 puts stdout "TEST #4a, should DEFAULT..."
 DispatchSample1 "not_in_list"
 puts stdout "TEST #5, should match #5,#6,#7..."
 DispatchSample1 "bar"
 puts stdout "TEST #6, should match #5,#6,#7..."
 DispatchSample1 "FOO"
 puts stdout "TEST #7, should match #5,#6,#7..."
 DispatchSample1 "BAR"
 
 ###############################################################################
 # series 2, do bad things
 ###############################################################################
 puts stdout "TEST #8, should not match anything..."
 DispatchSample2 "not_in_list"
 puts stdout ""
 
 puts stdout "TEST #9, should match, but not evaluate anything..."
 DispatchSample2 "NOEVAL"
 puts stdout ""
 
 puts stdout "TEST #10, should give error..."
 catch {DispatchSample3 "3"} dispatch_error
 puts stdout "ERROR: `` $dispatch_error ``"
 puts stdout ""
 
 puts stdout "TEST #11, should give error (malformed dispatch)..."
 catch {DispatchSample4 "1"} dispatch_error
 puts stdout "ERROR: `` $dispatch_error ``"
 puts stdout ""
 
 puts stdout "TEST #12, should match glob..."
 DispatchSample3 "4"
 
 puts stdout "TEST #13, should match regexp IP..."
 DispatchSample5 "198.102.29.10"
 
 puts stdout "TEST #14, should NOT match regexp..."
 DispatchSample5 "198.102.29.290"
 
 puts stdout "TEST #15, should NOT match regexp..."
 DispatchSample5 "*"
 
 puts stdout "TEST #16, should match regexp email..."
 DispatchSample5 "[email protected]"
 
 puts stdout "TEST #17, should match regexp hyperlink..."
 DispatchSample5 "<A HREF=\"http://www.scriptics.com/\">"
 
 puts stdout "TEST #18, should match command test..."
 DispatchSample6 "test"
 
 puts stdout "TEST #19, should match command test * 2..."
 DispatchSample6 "this_is_a_testthis_is_a_test"
 
 puts stdout "TEST #20, should match fake command..."
 set test20_var {\[fakecommand\]}
 DispatchSample6 $test20_var
 
 puts stdout "TEST #21, should match command test * 3 OR 4..."
 DispatchSample6 "this_is_a_testthis_is_a_testthis_is_a_test"
 
 puts stdout "TEST #22, should match command test * 3 OR 4..."
 DispatchSample6 "this_is_a_testthis_is_a_testthis_is_a_testthis_is_a_test"
 
 puts stdout "TEST #23, default string test..."
 DispatchSample7 "8"
 
 puts stdout "TEST #24, multiple test 1, should match 1, glob 1*, and default..."
 DispatchSample8 "1"
 
 puts stdout "TEST #25, multiple test 2, should match 2, glob 2*, and default..."
 DispatchSample8 "2"
 
 puts stdout "TEST #26, multiple test 3, should match default..."
 DispatchSample8 "3"
 
 puts stdout "TEST #27, invalid switch test, should give error..."
 catch {DispatchSample9 "3"} dispatch_error
 puts stdout "ERROR: `` $dispatch_error ``"
 
 puts stdout "TEST #28, switch-like argument after end of switches test, should match -notvalid..."
 DispatchSample10 ""

Version History

  07/Oct/2001 Version 1.00 -- initial version
  19/Nov/2002 Version 2.40 -- initial public release version
  06/May/2003 Version 2.60 -- updated, various internal changes
  21/Aug/2003 Version 2.70 -- updated, added -expr switch, minor tweaks

elfring 2003-11-01 Is there a relationship to the function library "liboop"? Can an adaptor be created to achieve a cooperation?

Alternate package by Andy Goth

AMG: Here is another command called [dispatch]. In addition to switch-like script execution, this command allows each script to have arguments, implemented in terms of argparse.

Code

package require Tcl 8.6
package require argparse
package provide dispatch 0.1

# dispatch --
# Table-driven script execution.
#
# The first argument is a list containing the method name and any number of
# arguments to the method.
#
# The second argument is the method table, which is a list alternating between
# method names and definitions.
#
# The method table is searched using unambiguous prefix matching on the method
# name.  There is no facility for defaults or other kinds of patterns.
#
# Method definitions are lists of zero or more elements.  The final element is
# the script body to be executed, and any preceding elements are used as initial
# arguments to [argparse], with the final argument being the input argument sans
# its first element, that being the method name.
#
# Argument parsing and script execution are performed in the caller's context,
# which is one of the main distinctions between [dispatch] and normal command
# dispatch using [namespace ensemble] or similar systems.
proc ::dispatch {input table} {
    # Look up the method definition in the method table.
    set method [dict get $table [tcl::prefix match -message method\
            [dict keys $table] [lindex $input 0]]]

    # Parse method arguments.
    if {[llength $method] > 1} {
        uplevel 1 [list ::argparse {*}[lrange $method 0 end-1]\
                [lrange $input 1 end]]
    } elseif {[llength $input] > 1} {
        return -code error "wrong # args: should be \"[lindex $input 0]\""
    }

    # Execute method body.
    uplevel 1 [lindex $method end]
}

Here's the pkgIndex.tcl:

package ifneeded dispatch 0.1 [list source [file join $dir dispatch.tcl]]

Examples

% package require dispatch
0.1
% set table {
foo {-boolean {
    -hello
    {-world= -default 42}
} {
    puts "method: foo"
    if {$hello} {
        puts "world: $world"
    }
}} bar {{
    puts "method: bar"
}}}
% dispatch {foo -hello} $table
method: foo
world: 42
% set hello
1
% set world
42
% dispatch bar $table
method: bar
% dispatch ba $table
method: bar
% dispatch quux $table
bad method "quux": must be foo or bar
% dispatch {bar -hello} $table
wrong # args: should be "bar"
% dispatch {foo -world} $table
-world requires an argument

Ideas

I've tried to keep things as simple as possible for now, so I'm unlikely to do any of the following until I have a real need.

Hierarchical methods

Currently, hierarchical methods can be implemented via nested invocation of [dispatch]. Flattening the implementation by allowing the method names to be lists might be an attractive alternative.

dispatch $input {
{list search} {{...} {...}}
{list sort}   {{...} {...}}
{dict append} {{dictVar key strings*} {...}}
{dict exists} {{dictVal keys*!} {...}}
}

Default methods

Maybe some way to specify default handlers? Or perhaps also wildcard and other kinds of pattern matching? This would lose the dict performance benefits and would complicate the code, so I have not implemented it. Even simply having "default" would not work with dict. "default" should only be special when it is the final key, and that same word "default" may also be used earlier and be interpreted literally. dict is supposed to be agnostic about key ordering, and it does not allow keys to appear multiple times.

One possibility is to move away from switch compatibility and jettison the word "default". Instead, bring in the hierarchical methods idea from above, while allowing one method name list to be a prefix of another. Execute the method with the longest matching name prefix, then (as is current) assign the subsequent input arguments via argparse.

dispatch {a b c d e} {
{a b c} {{D E} {...}}
{a b}   {{method args*} {error "unknown method: a b $method"}}
{w x y} {{...} {...}}
w       {{...} {...}}
{}      {{method args*} {error "unknown method: $method"}}
}

Or something like that. The above example isn't very useful though since there's already much better error reporting listing the valid methods.

Customizing tcl::prefix

Maybe don't always call the input a "method"; let the user specify the -message switch to tcl::prefix. Also, maybe let the user specify -exact.

Category Package