The "official" or "maintained" version of the code below is at tcl-hacks in modules/options-0.tm, accompanied by a TIP#288-capable version of arguments in modules/tip288-0.tm.
Supporting options like the core commands do is a common itch for Tcl'ers, as evidenced by the number of pages in Category Argument Processing! Here's a version I found recently in an old code folder, dusted off and have adopted as my go-to. The main features are that its use should be obvious, good error messages are generated and you don't end up writing a proc wrapper that takes two or more multi-line arguments.
Here's a demo:
proc what {args} {
options {{-loud} {-colour red green blue black} {-count 5}}
arguments {this {that {}} args}
foreach name [info locals] {
puts "$name = [set $name]"
}
}Most of that should be obvious, so I'll just show off how it handles errors:
% what wrong # args: should be "what this ?that? ?args ...?" % what -co la Ambiguous option -co: maybe one of -colour -count % what -colour greenish Bad colour "greenish": must be one of red green blue black
And the module, which is hopefully short enough to act as its own documentation (and encouragement to extend!).
# commented sections are questionable support for validation of arguments (not opts - conflicts with multi-value form).
namespace eval options {
proc options {args} {
while {[llength $args] > 1} {
if {[string match [lindex $args 0]* -arrayvariable]} {
set args [lassign $args _ value]
set name -arrayvariable
set options($name) $value
} else {
error "Unknown option \"[lindex $args 0]\": must be one of -arrayvariable"
}
}
if {[info exists options(-arrayvariable)]} {
set upset [format {apply {{name value} {
uplevel 2 [list set %s(-$name) $value]
}}} $value]
} else {
set upset [format {apply {{name value} {
uplevel 2 [list set $name $value]
}}}]
}
# parse optspec
set spec [lindex $args 0]
foreach optspec $spec {
set name [lindex $optspec 0]
switch [llength $optspec] {
1 {
dict set opts $name type 0 ;# flag
{*}$upset [string range $name 1 end] 0
#dict set opts $name value 0
}
2 {
dict set opts $name type 1 ;# arbitrary value
dict set opts $name default [lindex $optspec 1]
{*}$upset [string range $name 1 end] [lindex $optspec 1]
#dict set opts $name value [lindex $optspec 1]
}
default {
dict set opts $name type 2 ;# choice
dict set opts $name default [lindex $optspec 1]
dict set opts $name values [lrange $optspec 1 end]
{*}$upset [string range $name 1 end] [lindex $optspec 1]
}
}
}
# get caller's args
upvar 1 args argv
for {set i 0} {$i<[llength $argv]} {} {
set arg [lindex $argv $i]
if {![string match -* $arg]} {
break
}
incr i
if {$arg eq "--"} {
break
}
set candidates [dict filter $opts key $arg*]
switch [dict size $candidates] {
0 {
return -code error -level 2 "Unknown option $arg: must be one of [dict keys $opts]"
}
1 {
dict for {name spec} $candidates {break}
set name [string range $name 1 end]
dict with spec {} ;# look out
if {$type==0} {
set value 1
} else {
if {[llength $argv]<($i+1)} {
return -code error -level 2 "Option $name requires a value"
}
set value [lindex $argv $i]
if {$type==2} {
set is [lsearch -all -glob $values $value*]
switch [llength $is] {
1 {
set value [lindex $values $is]
}
0 {
return -code error -level 2 "Bad $name \"$value\": must be one of $values"
}
default {
return -code error -level 2 "Ambiguous $name \"$value\": could be any of [lmap i $is {lindex $values $i}]"
}
}
}
incr i
}
{*}$upset $name $value
}
default {
return -code error -level 2 "Ambiguous option $arg: maybe one of [dict keys $candidates]"
}
}
}
set argv [lrange $argv $i end]
}
proc formatArgspec {argspec} {
foreach arg $argspec {
if {[llength $arg]>1} {
lappend res "?[lindex $arg 0]?"
} elseif {$arg eq "args"} {
lappend res "?args ...?"
} else {
lappend res $arg
}
}
return [join $res " "]
}
proc arguments {argspec} {
upvar 1 args argv
for {set i 0} {$i<[llength $argv]} {incr i} {
if {$i >= [llength $argspec]} {
return -code error -level 2 "wrong # args: should be \"[lindex [info level -1] 0] [formatArgspec $argspec]\""
}
set name [lindex $argspec $i 0]
if {$name eq "args"} {
uplevel 1 [list set args [lrange $argv $i end]]
return
}
set value [lindex $argv $i]
# set test [lindex $argspec $i 2]
# if {$test != ""} {
# set valid [uplevel 1 $test $value]
# if {!$value} {
# return -code error -level 2 "Invalid $name \"$value\", must be $test"
# }
# }
uplevel 1 [list set $name $value]
}
# defaults:
for {} {$i < [llength $argspec]} {incr i} {
set as [lindex $argspec $i]
if {[llength $as]==1} {
if {$as ne "args"} {
return -code error -level 2 "wrong # args: should be \"[lindex [info level -1] 0] [formatArgspec $argspec]\""
}
upvar 1 args args
set args [lrange $argv $i end]
return
}
lassign $as name value
# set test [lindex $argspec $i 2]
# if {$test != ""} {
# set valid [uplevel 1 $test $value]
# if {!$value} {
# return -code error -level 2 "Invalid $name \"$value\", must be $test"
# }
# }
uplevel 1 [list set $name $value]
}
}
namespace export options arguments
}
namespace import options::*aspect 2015-03-16 development notes: kap raised a question about gathering options in an array, which make me think that having options return a dict of the variables it has set might be a good idea. The current return value of $args isn't particularly useful, and wasn't designed.
Note I have a TIP#288 implementation in my local version of arguments, which will make it into a chiselapp repo once I can find a spare tuit.