options-0.tm

#!/usr/bin/tclsh

# neat little options/arguments parser I apparently wrote.
# commented sections are questionable support for validation of arguments (not opts - conflicts with multi-value form).

namespace eval options {

    proc options {args} {
        # parse optspec
        foreach optspec $args {
            set name [lindex $optspec 0]
            switch [llength $optspec] {
                1 {
                    dict set opts $name type 0 ;# flag
                    uplevel 1 [list set [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]
                    uplevel 1 [list set [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]
                    uplevel 1 [list set [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} {
                        uplevel 1 [list set $name 1]
                        #dict set opts $name value 1
                    } else {
                        if {[llength $argv]<($i+1)} {
                            return -code error -level 2 "Option $name requires a value"
                        }
                        set val [lindex $argv $i]
                        if {$type==2} {
                            set is [lsearch -all -glob $values $val*]
                            switch [llength $is] {
                                1 {
                                    set val [lindex $values $is]
                                }
                                0 {
                                    return -code error -level 2 "Bad $name \"$val\": must be one of $values"
                                }
                                default {
                                    return -code error -level 2 "Ambiguous $name \"$val\": could be any of [lmap i $is {lindex $values $i}]"
                                }
                            }
                        }
                        uplevel 1 [list set $name $val]
                        incr i
                    }
                }
                default {
                    return -code error -level 2 "Ambiguous option $arg: maybe one of [dict keys $candidates]"
                }
            }
        }
        set argv [lrange $argv $i end]
    }

    proc formatArgspec {argspec} {
        join [lmap arg $argspec {
            if {[llength $arg]>1} {
                K "?[lindex $arg 0]?"
            } elseif {$arg eq "args"} {
                K "?args ...?"
            } else {
                K $arg
            }
        }] " "
    }

    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::*
#
#proc test {args} {
#    options {-flag} {-flip {}} {-value 100} {-colour red green blue black}
#    arguments {rabbit {poo yes} args}
#    foreach name [info locals] {
#        puts "$name = [set $name]"
#    }
#    puts {}
#}
#
#test hehe
#test -fla hehe
#test -fli lalala hehe
#test -val 230 hehe
#test hjg hgj hj ghjgjh
#test -col gr hg h
#test