Updated 2015-08-27 14:12:52 by aspect

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.