** Code **

======
# autoopts v0.1.0
# This module automatically processes command line arguments and generates a
# usage message based on the arguments that your main proc accepts. To use it,
# simply source this file and call ::autoopts::go ?your-main-proc?.
# Copyright (c) 2017 dbohdan
package require Tcl 8.5

namespace eval ::autoopts {}

proc ::autoopts::has-prefix name {
    return [regexp {^--?} $name]
}

proc ::autoopts::generate-spec proc {
    set spec {named {} positional {}}
    foreach arg [info args $proc] {
        set info {}
        dict set info name $arg
        if {[info default $proc $arg default]} {
            dict set info default $default
        }
        if {[has-prefix $arg]} {
            dict lappend spec named $info
        } else {
            dict lappend spec positional $info
        }
    }
    return $spec
}

proc ::autoopts::me {} {
    return [file tail [info script]]
}

proc ::autoopts::generate-usage spec {
    set usage "usage: [me]"
    foreach info [dict get $spec positional] {
        set name [dict get $info name]
        if {[dict exists $info default]} {
            append usage " \[$name\]"
        } else {
            append usage " $name"
        }
    }
    foreach info [dict get $spec named] {
        set name [dict get $info name]
        if {[dict exists $info default]} {
            append usage " \[$name [dict get $info default]\]"
        } else {
            append usage " $name [string toupper [string trimleft $name -]]"
        }
    }
    return $usage
}

proc ::autoopts::parse {spec arguments} {
    set named [dict get $spec named]
    set positional [dict get $spec positional]

    set count [llength $arguments]
    set eon 0 ;# End of named arguments.
    set names {}
    set pos 0 ;# Number of positional arguments encountered.
    set values {} ;# Result.
    foreach info $named {
        lappend names [dict get $info name]
    }

    for {set i 0} {$i < $count} {incr i} {
        set arg [lindex $arguments $i]
        if {[has-prefix $arg] && !$eon} {
            if {$arg eq {--}} {
                set eon 1
                continue
            }
            if {$arg ni $names} {
                error "unknown option: $arg"
            }
            if {$i + 1 < $count} {
                dict set values $arg [lindex $arguments $i+1]
            } else {
                error "missing value for option $arg"
            }
            incr i
        } else {
            if {$pos >= [llength $positional]} {
                error {too many positional arguments}
            }
            dict set values [dict get [lindex $positional $pos] name] $arg
            incr pos
        }
    }

    set keys [dict keys $values]
    for {set i $pos} {$i < [llength $positional]} {incr i} {
        set info [lindex $positional $i]
        if {[dict exists $info default]} {
            dict set values [dict get $info name] [dict get $info default]
        } else {
            error {too few positional arguments}
        } 
    }
    foreach info $named {
        set name [dict get $info name]
        if {$name ni $keys} {
            if {[dict exists $info default]} {
                dict set values $name [dict get $info default]
            } else {
                error "missing required option $name"
            }
        }
    }
    return $values
}

proc ::autoopts::invoke {proc values} {
    set procArgs {}
    foreach arg [info args $proc] {
        lappend procArgs [dict get $values $arg]
    }
    $proc {*}$procArgs
}

proc ::autoopts::go {{proc main}} {
    set spec [generate-spec $proc]
    if {[string trim $::argv] in {-h --help}} {
        puts stderr [generate-usage $spec]
        exit 0
    }
    if {[catch {
        set values [parse $spec $::argv]
    } err]} {
        puts stderr $err
        puts stderr [generate-usage $spec]
        exit 1
    }
    invoke $proc $values
}

# Testing.

proc ::autoopts::assert-equal {actual expected} {
    if {$actual ne $expected} {
        error "expected \"$expected\", but got \"$actual\""
    }
}

proc ::autoopts::test {} {
    proc ::autoopts::foo {-n --hello} {
        return [list ${-n} ${--hello}]
    }
    proc ::autoopts::bar {inputfile {outputfile -} {--format pdf}} {
        return [list $inputfile $outputfile ${--format}]
    }
    set fooSpec {named {{name -n} {name --hello}} positional {}}
    set barSpec {named {{name --format default pdf}}\
                 positional {{name inputfile} {name outputfile default -}}}

    # generate-spec.

    set spec [generate-spec foo]
    assert-equal $spec $fooSpec
    assert-equal [generate-usage $spec] "usage: [me] -n N --hello HELLO"

    set spec [generate-spec bar]
    assert-equal $spec $barSpec
    assert-equal [generate-usage $spec] \
                 "usage: [me] inputfile \[outputfile\] \[--format pdf\]"


    # parse.

    catch {parse $fooSpec {}} err
    assert-equal $err {missing required option -n}

    catch {parse $fooSpec {-n 5}} err
    assert-equal $err {missing required option --hello}

    catch {parse $fooSpec foo} err
    assert-equal $err {too many positional arguments}

    catch {parse $fooSpec {-n 5 --hello world --with-cheese}} err
    assert-equal $err {unknown option: --with-cheese}

    catch {parse $fooSpec {-n 5 --hello world --with-cheese no}} err
    assert-equal $err {unknown option: --with-cheese}

    assert-equal [parse $fooSpec {-n 5 --hello world}] {-n 5 --hello world}


    catch {parse $barSpec {}} err
    assert-equal $err {too few positional arguments}

    catch {parse $barSpec {x y z}} err
    assert-equal $err {too many positional arguments}

    catch {parse $barSpec {x --what? z}} err
    assert-equal $err {unknown option: --what?}

    assert-equal [parse $barSpec foo.doc] \
                 {inputfile foo.doc outputfile - --format pdf}

    assert-equal [parse $barSpec {foo.doc bar.pdf}] \
                 {inputfile foo.doc outputfile bar.pdf --format pdf}

    assert-equal [parse $barSpec {foo.doc bar.xlsx --format xlsx}] \
                 {inputfile foo.doc outputfile bar.xlsx --format xlsx}

    # invoke.

    assert-equal [invoke foo {-n 42 --hello universe}] {42 universe}
    assert-equal [invoke bar {
        inputfile /dev/zero outputfile /dev/null --format N/A
    }] {/dev/zero /dev/null N/A}

    rename ::autoopts::foo {} 
    rename ::autoopts::bar {} 
}

# If this is the main script...
if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
    ::autoopts::test
}

======


** Use example **

*** Code ***

======
#! /usr/bin/env tclsh
proc main {{input -} {--shift 4}} {
    set ch [expr {$input eq "-" ? "stdin" : [open $input]}]
    while {[gets $ch line] > 0} {
        puts [string repeat { } ${--shift}]$line
    }
}

source autoopts.tcl
::autoopts::go
======

*** Session ***

======
$ ./autoopts-example.tcl --help
usage: autoopts-example.tcl [input] [--shift 4]
$ ./autoopts-example.tcl --wrong
unknown option: --wrong
usage: autoopts-example.tcl [input] [--shift 4]
======


<<categories>>Argument Processing | Package