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 "billy@mistachkin.com"
 
 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 <joe@mistachkin.com>
 #  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 <joe@mistachkin.com>
 #  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 "me@me.org"
 
 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?

----
[category package]