hkoba:
switch with regexp variable capturing.
Note: As of Tcl 8.5, the built in switch command supports regex variable capture natively via the "-matchvar" option.
Example -
# source this and
namespace import switch-regexp::*
foreach somevar {{** !!} {100 200}} {
switch-regexp -- $somevar {
{^(\d+)\s+(\d+)} {1 2} {puts "You hit number matches $1 and $2"}
{^(\S+)\s+(\S+)} {1 2} {puts "You hit matches $1 and $2"}
}
}This produces:
You hit matches ** and !!
You hit number matches 100 and 200
# -*- mode: tcl; tab-width: 8 -*-
# $Id: 13839,v 1.7 2005-12-17 07:01:54 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
}
