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.
<<categories>> Package