[hkoba]: [switch] with regexp variable capturing. 

Example -

 # source this and
 namespace import switch-regexp::*
 
 foreach somevar {{** !!} {100 200}} {
   switch-regexp -- $somevar {
      {^(\S+)\s+(\S+)} {1 2} {puts "You hit matches $1 and $2"}
      {^(\d+)\s+(\d+)} {1 2} {puts "You hit number matches $1 and $2"}
   }
 }

This produces:

  You hit matches ** and !!
  You hit matches 100 and 200

--

  # -*- mode: tcl; tab-width: 8 -*-
  # $Id: 13839,v 1.3 2005-03-18 07:01:32 jcw Exp $
  
  package require cmdline
  namespace eval switch-regexp {
      namespace export switch-regexp*
      proc switch-regexp args {
        prepare $args opts value patlist varlist cmdlist group
        set match [match br $value $opts $patlist $varlist $cmdlist $group]
        if {$br < 0} {
            return $br
        }
        set code [catch {
            uplevel 1 [list [namespace current]::dispatch $br \
                           $value $match $varlist $cmdlist $group]
        } result]
        eval [list return] [control $code $result]
      }
      proc control {code result} {
        switch -exact -- $code {
            0 {return $result}
            1 {
                list -code error -errorcode $::errorCode \
                    -errorinfo $::errorInfo $result
            }
            2 {list -code return $result}
            3 {list -code break}
            4 {list -code continue}
            default {list -code $code $result}
        }
      }
      proc match {brVar value opts patlist varlist cmdlist branch} {
        upvar 1 $brVar br
        set br -1
        set match [eval [list regexp -inline -indices] \
                       $opts [list [join $patlist |] $value]]
        if {![llength $match]} {
            return
        }
        set br [find-matched-branch $match $branch]
        if {$br < 0} {
            error "Can't find branch! match is $match"
        }
        set match
      }
      proc prepare {arglist args} {
        foreach vn {opts value patlist varlist cmdlist group} an $args {
            upvar 1 $vn $vn
        }
        set opts {}
        foreach {o v} [cmdline::getoptions arglist {
            {expanded} {line} {linestop} {lineanchor} {nocase}
            {start.arg ""}
        }] {
            if {$o ne "start" && $v != 0} {
                lappend opts -$o
            } elseif {$o eq "start" && $v ne ""} {
                lappend opts -$o $v
            }
        }
        if {[llength $arglist] != 2} {
            error "Usage: ?opts..? value {pattern vars body ...}"
        }
        foreach {value body} $arglist break
        set patlist {}
        set varlist {}
        set cmdlist {}
        set group {}; set lastgroup 1
        foreach {pat var cmd} $body {
            lappend patlist (?:$pat)
            lappend varlist $var
            lappend cmdlist $cmd
            lappend group $lastgroup
            incr lastgroup [llength $var]
        }
      }
      proc dispatch {br value match varlist cmdlist branch} {
        # puts "match=$match\nbr=$br@$branch\n[branch-get $match $branch $br]"
        propagate $value [lindex $varlist $br] [branch-get $match $branch $br]\
            1
        set code [catch {uplevel 1 [lindex $cmdlist $br]} result]
        eval [list return] [control $code $result]
      }
      proc branch-range {branch nth max} {
        if {[llength $branch] - 1 <= $nth} {
            set end $max
        } else {
            set end [expr {[lindex $branch [expr {$nth + 1}]] - 1}]
        }
        list [lindex $branch $nth] $end
      }
      proc branch-get {list branch nth} {
        foreach {first last} [branch-range $branch $nth [llength $list]]\
            break
        lrange $list $first $last
      }
      proc find-matched-branch {match branch} {
        set i 1; set br 0
        set range [branch-range $branch $br [llength $match]]
        foreach m [lrange $match 1 end] {
            if {$i >= [lindex $range end]} {
                # puts "incr br($br). $i vs $range"
                set range [branch-range $branch [incr br] [llength $match]]
            }
            # puts $i=$m=$br=<$range>
            if {[is-matched $m]} {
                return $br
            }
            incr i
        }
        return -1
      }
      proc is-matched pair {
        expr {[lindex $pair 0] > -1 && [lindex $pair 1] > -1}
      }
      proc range {string range} {
        eval [list string range $string] $range
      }
      proc propagate {value vars ranges {level 0}} {
        if {[set l1 [llength $vars]] != [set l2 [llength $ranges]]} {
            error "length mismatch: $l1 != $l2\n$vars\n$ranges"
        }
        incr level 1
        foreach vn $vars range $ranges {
            upvar $level $vn var
            set var [range $value $range]
        }
      }
      proc @ varName {
        upvar 1 $varName var
        list $varName $var
      }
      proc switch-regexp-debug args {
        prepare $args opts value patlist varlist cmdlist group
        list [@ opts] [@ value] [@ patlist] [@ varlist] [@ cmdlist] [@ group]
      }
  }

And short test cases.

  
  if {[info exists ::argv0] && [info script] == $::argv0} {
      package require tcltest
      namespace import tcltest::*
  
      set input foobar
      switch-regexp::prepare [list -expanded $input {
        ^f(.*) rest {puts $rest}
        [ob]* ob {puts $ob}
      }] opts value patlist varlist cmdlist group
  
      set i 0
      test prepare-[incr i] {arg check} {set opts} {-expanded}
      test prepare-[incr i] {arg check} {set value} $input
      test prepare-[incr i] {arg check} {set patlist} {(?:^f(.*)) {(?:[ob]*)}}
      test prepare-[incr i] {arg check} {set varlist} {rest ob}
      test prepare-[incr i] {arg check} {set group} {1 2}
  
      array unset res
      test dispatch-1-returned-branch {should match first branch} {
        switch-regexp::switch-regexp {foo !!} {
            {^(\d+)\s+(\d+)} {1 2} {
                puts "hello 0"
                set res(branch) 0
            }
            {^(\S+)\s+(\S+)} {1 2} {
                puts "hello 1"
                set res(branch) 1
            }
        }
      } 1
      test dispatch-1-executed-branch {should exec first branch} {
        set res(branch)
      } 1
      test dispatch-1-vars {should match first branch} {
        list $1 $2
      } {foo !!}
      unset 1 2
  
      test dispatch-1-break {break} {
        set i 0
        foreach value {{foo !!} {12 23}} {
            switch-regexp::switch-regexp $value {
                {^(\d+)\s+(\d+)} {1 2} {
                    puts "hello 0"
                    set res(branch) 0
                }
                {^(\S+)\s+(\S+)} {1 2} {
                    break
                }
            }
            incr i
        }
        set i
      } 0
      unset 1 2
      test dispatch-1-continue {continue} {
        set i 0
        foreach value {{foo !!} {12 23}} {
            switch-regexp::switch-regexp $value {
                {^(\d+)\s+(\d+)} {1 2} {
                    puts "decimals"
                    set res(branch) 0
                }
                {^(\S+)\s+(\S+)} {1 2} {
                    continue
                }
            }
            puts "incrementing"
            incr i
        }
        list $i $1 $2
      } {1 12 23}
      unset 1 2
      test dispatch-1-return {return} {
        proc t {} {
            set i 0
            foreach value {{foo !!} {12 23}} {
                switch-regexp::switch-regexp $value {
                    {^(\d+)\s+(\d+)} {1 2} {
                        error "should not leached here"
                    }
                    {^(\S+)\s+(\S+)} {1 2} {
                        return FOO
                    }
                }
                incr i
            }
            list $i $1 $2
        }
        t
      } FOO
  
      test impl-branch-1 {find matched group} {
        switch-regexp::branch-range {1 3 7} 0 9
      } {1 2}
      test impl-branch-1 {find matched group} {
        switch-regexp::branch-range {1 3 7} 1 9
      } {3 6}
      test impl-branch-1 {find matched group} {
        switch-regexp::branch-range {1 3 7} 2 9
      } {7 9}
  
      test impl-branch {find matched group} {
        set group [switch-regexp::find-matched-branch {
            {2 4}  {-1 -1} {-1 -1} {-1 -1} {-1 -1} {3 3} {4 4}
        } {1 3 6}]
      } 2
      test impl-branch {find matched group} {
        set group [switch-regexp::find-matched-branch {
            {2 4} {-1 -1} {-1 -1} {3 3} {4 4} {-1 -1} {-1 -1}
        } {1 3 6}]
      } 1
      test impl-branch {find matched group} {
        set group [switch-regexp::find-matched-branch {
            {2 4}  {3 3} {4 4} {-1 -1} {-1 -1} {-1 -1} {-1 -1}
        } {1 3 6}]
      } 0
  }