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.
Main Source File (dispatch.tcl)
############################################################################### # # Tcl dispatch command # # Copyright (c) 2001-2002 by Joe Mistachkin. All rights reserved. # # written by: Joe Mistachkin <[email protected]> # created on: 10/07/2001 # modified on: 09/12/2002 # ############################################################################### # # 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" "-glob" "-regexp" "-multiple"] # 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.4" 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 { 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 } { # # 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 # value 1 means "switch enabled" set switches($switch_name) "1" # value 1 means "processed switch" set result "1" } 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 { {dispatch_argument1 ""} {dispatch_argument2 ""} {dispatch_argument3 ""} {dispatch_argument4 ""} {dispatch_argument5 ""} {dispatch_argument6 ""} {dispatch_argument7 ""} {dispatch_argument8 ""} } { global dispatch_maximum_arguments global dispatch_argument_error global dispatch_switch_error global dispatch_switches # # This is the OUTER dispatch proc. It handles translation of switches # and then forwards the request to dispatch_internal. # # NOTE: if you wish to add more switches, you have to have more arguments too... # set result "" set arguments(1) $dispatch_argument1 set arguments(2) $dispatch_argument2 set arguments(3) $dispatch_argument3 set arguments(4) $dispatch_argument4 set arguments(5) $dispatch_argument5 set arguments(6) $dispatch_argument6 set arguments(7) $dispatch_argument7 set arguments(8) $dispatch_argument8 set switches(exact) "0" set switches(nocase) "0" set switches(glob) "0" set switches(regexp) "0" set switches(multiple) "0" set switches(end) "0" # # this loop is trying to find "the first non-switch argument"... # set invalid "0" set found "0" set index "1" while {(($index <= $dispatch_maximum_arguments) && ($found == "0") && ($invalid == "0"))} { set is_switch [valid_switch $arguments($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 $arguments($index) switches # skip to next index now set index [expr {$index + "1"}] } "4" { # # found FINAL switch, process it # check_switch $arguments($index) switches # 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 { if {$index < $dispatch_maximum_arguments} then { set dispatch_string $arguments($index) set index [expr {$index + "1"}] set dispatch_body $arguments($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(glob) $switches(regexp) $switches(multiple) $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" } } switch -exact -- $dispatch_error { "1" { error $dispatch_argument_error } "2" { error $dispatch_switch_error } } return $result } proc dispatch_internal { dispatch_exact dispatch_nocase dispatch_glob dispatch_regexp dispatch_multiple 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 catch {unset variable_value} # # get variable value from calling proc # (could this be done better with upvar?) # set variable_value [uplevel $dispatch_level 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 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 { # 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 # set result [uplevel $dispatch_level $this_body] set evaluated "1" set matched "0" if {$dispatch_multiple == "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 by Joe Mistachkin. All rights reserved. # # written by: Joe Mistachkin <[email protected]> # created on: 10/07/2001 # ############################################################################### # 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 -multiple -- $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 -multiple -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