Version 7 of autoopts

Description

dbohdan 2017-08-14: The following Tcl module automates processing of command line arguments. It was inspired by Perl 6, which does a similar thing quite elegantly . In short, this module automatically generates a command line interface for your Tcl program based on the arguments that its main proc takes. It maps the proc's arguments whose names are prefixed with dashes (e.g., -a or --arg) to named command line arguments (options) and other proc arguments to positional command line arguments. E.g., proc main {filename -a {--factor 2x}} ... will result in usage: yourscript.tcl -a A --factor 2x -- filename. Proc arguments with default values are mapped to optional command line arguments, named or positional; other arguments are considered mandatory. If some of the mandatory arguments are missing or unrecognized extra command line arguments are given, autoopts will output an informative error message, print an automatically generated usage note, and exit. It will also output a usage message if the user gives the command line argument -h or --help.

To use this autoopts, source it and call ::autoopts::go ?description? ?your-main-proc?.

Download with wiki-reaper: wiki-reaper 48940 2 > autoopts-0.2.0.tm

Use example

Code

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

source autoopts.tcl
::autoopts::go {indenter pro v1.0.1 -- indents input with spaces}

Shell transcript

$ ./autoopts-example.tcl --help
indenter pro v1.0.1 - indents input with spaces
usage: autoopts-example.tcl [--indent 4] [--] [input]

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

$ ./autoopts-example.tcl file1 file2 file3
too many positional arguments
usage: autoopts-example.tcl [--indent 4] [--] [input]

$ ./autoopts-example.tcl --indent
missing value for option --indent
usage: autoopts-example.tcl [--indent 4] [--] [input]

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

Code

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

namespace eval ::autoopts {
    variable version 0.2.0
}

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

# Generate a command line argument spec based on the arguments the proc $proc
# takes. The spec follows the format
# {named {named1 ... namedN} positional {positional1 .. positionalM}}, where
# each list item namedI or positionalJ is a dictionary {name foo ?default bar?}.
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]]
}

# Take a spec generated by [generate-spec] and return a human-readable usage
# message.
proc ::autoopts::generate-usage spec {
    set usage "usage: [me]"
    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 -]]"
        }
    }
    if {[llength [dict get $spec positional]] > 0} {
        append usage { [--]}
        foreach info [dict get $spec positional] {
            set name [dict get $info name]
            if {[dict exists $info default]} {
                append usage " \[$name\]"
            } else {
                append usage " $name"
            }
        }
    }
    return $usage
}

# Parse the command line argument list $arguments according to the spec $spec.
# Returns a dictionary {arg1 value1 ... argN valueN}.
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
}

# Inspect proc $proc for argument names and call it with argument values in the
# dictionary $values.
proc ::autoopts::invoke {proc values} {
    set procArgs {}
    foreach arg [info args $proc] {
        lappend procArgs [dict get $values $arg]
    }
    $proc {*}$procArgs
}

# Invoke $proc with arguments based on $::argv. If some mandatory command line
# arguments are missing or there are too many of them, print an error message
# and usage to stderr and exit with exit status 1. If $::argv consists of just
# {-h} or {--help}, print usage to stderr and exit with status 0.
proc ::autoopts::go {{description {}} {proc main}} {
    set spec [generate-spec $proc]
    if {[string trim $::argv] in {-h --help}} {
        puts stderr $description
        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] \[--format pdf\] \[--\] inputfile \[outputfile\]"

    # 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
}

arjen - 2017-08-15 14:01:13

Just a few remarks:

Shouldn't invoke use uplevel to make sure that the procedure is called in the right namespace and that variables that are referred by name are correctly upvar'ed?
The test cases should include an example where the procedure lives in a different namespace.
It is a common convention to capitalise the names of private procedures. An easy way to see what you may and may not use.

Category Argument Processing

Category Package