I've spent some time this evening hacking on a set of tools to ease my pain when I need a command with subcommands that parses its arguments in a manner that is compatible with proc.
I've got something that sort of works here, good enough for the serial command that I was implementing anyway:
# subcommands.tcl # Copyright April 13, 2005 - Pierre Coueffin
proc subcommand {cmd arglname commands} {
set code [list switch -exact -- $cmd]
set switches {}
foreach {c a b} $commands {
set b "nameArgs [list $a] \$[set arglname]\n$b"
lappend switches $c $b
}
lappend code $switches
uplevel 1 $code}
proc nameArgs {prototype argl} {
set mandatory {}
set optional {}
set args [lindex $prototype end]
if {! [string match $args args]} {
set args {}
upvar args v
set v {}
} else {
set prototype [lrange $prototype 0 end-1]
}
foreach proto $prototype {
switch [llength $proto] {
0 {
error "You can't have an argument with no name."
}
1 {
if {[llength $optional] > 0} {
error "You can't have a mandatory argument after an optional one."
}
lappend mandatory $proto
}
2 {
foreach part $proto {
lappend optional $part
}
}
default {
error "too many fields in argument specifier \"$proto\""
}
}
}
if {[llength $argl] < [llength $mandatory]} {
set errmsg "wrong # args: should be \"$mandatory"
foreach {opt default} $optional {
append errmsg " ?$opt?"
}
append errmsg " $args\""
error $errmsg
}
foreach name $mandatory arg [lrange $argl 0 [llength $mandatory]] {
upvar $name v
set v $arg
}
set argl [lrange $argl [llength $mandatory] end]
if {[llength $argl] > [expr [llength $optional] / 2]} {
if {$args == {}} {
set errmsg "wrong # args: should be \"$mandatory"
foreach {opt default} $optional {
append errmsg " ?$opt?"
}
append errmsg "\""
error $errmsg
}
upvar args v
set len [expr [llength $optional] / 2]
set v [lrange $argl $len end]
set argl [lrange $argl 0 $len]
}
set i 0
foreach {opt default} $optional arg $argl {
upvar $opt v
if {[llength $argl] <= $i} {
set v $default
} else {
set v $arg
}
incr i
}
return}