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 ?your-main-proc?.
#! /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$ ./autoopts-example.tcl --help
usage: autoopts-example.tcl [--shift 4] [--] [input]
$ ./autoopts-example.tcl --wrong
unknown option: --wrong
usage: autoopts-example.tcl [--shift 4] [--] [input]
$ ./autoopts-example.tcl file1 file2 file3
too many positional arguments
usage: autoopts-example.tcl [--shift 4] [--] [input]
$ ./autoopts-example.tcl --shift
missing value for option --shift
usage: autoopts-example.tcl [--shift 4] [--] [input]
$ ./autoopts-example.tcl ./autoopts-example.tcl --shift 11
#! /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
}
}# autoopts v0.1.1
# 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 ?your-main-proc?.
# Copyright (c) 2017 dbohdan
# License: MIT
package require Tcl 8.5
namespace eval ::autoopts {
variable version 0.1.1
}
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 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 -]]"
}
}
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
}
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
}