#!/usr/bin/tclsh
#******************************************************************************
# getopts
#
# Parse the options from argvret into the array optsret. Optstr is a string
# of valid option letters, with a colon following each non-boolean option
# letter (each option which takes an option argument).
#
# Options start with "-", except for the non-options "--", which is skipped
# over, and "-". Specifying the bundled option "-" is not allowed. Option
# processing terminates upon encountering the first non-option. Multiple
# options can be bundled into a single argument. The value of non-boolean
# options is taken from the remainder of the argument or the next argument
# if the remainder is empty.
#
# On error, argvret is not modified, optsret(error) contains an error
# message, optsret(opt) contains the offending option, and -1 is returned.
#
# On success, the parsed options are removed from argvret, optsret(error)
# and optsret(opt) contain an empty string, and 0 is returned. For each
# boolean option, the corresponding element of optsret is set to 0 (false)
# or 1 (true). For non-boolean options, the corresponding element of
# optsret contains whatever value was specified. For non-boolean options
# which are not specified, the corresponding element of optsret is not
# created and/or modified.
proc getopts { optstr argvret optsret } {
upvar $argvret argv
upvar $optsret opts
# initialize opts array with all boolean options set to 0 (false)
set opts(error) [ set opts(opt) "" ]
set opts_list [ split $optstr "" ]
for { set idx 0 } { $idx < [ llength $opts_list ] } { incr idx } {
if {[ lindex $opts_list [ expr $idx+1 ]] == ":" } {
incr idx
} else {
set opts([ lindex $opts_list $idx ]) 0
}
}
set arg_idx 0
while { $arg_idx < [ llength $argv ]} {
set curr_arg [ lindex $argv $arg_idx ]
if {[ string index $curr_arg 0 ] != "-" } { break }
if { $curr_arg == "-" } { break }
if { $curr_arg == "--" } { incr arg_idx; break }
incr arg_idx
set ch_idx 1
while {1} {
set opt_ch [ string index $curr_arg $ch_idx ]
if { $opt_ch == "" } { break }
incr ch_idx
if { $opt_ch == "-" } {
set opts(error) "invalid option -"
set opts(opt) "-"
return -1
}
set pos [ string first $opt_ch $optstr ]
if { $pos < 0 || ( $opt_ch == ":" && $pos > 0 )} {
set opts(error) "invalid option $opt_ch"
set opts(opt) $opt_ch
return -1
}
if {[ string index $optstr [ incr pos ]] != ":" } {
set opts($opt_ch) 1
continue
}
set optarg [ string range $curr_arg $ch_idx end ]
if { $optarg == "" } {
if { $arg_idx >= [ llength $argv ]} {
set opts(error) "missing argument for option $opt_ch"
set opts(opt) $opt_ch
return -1
}
set optarg [ lindex $argv $arg_idx ]
incr arg_idx
}
set opts($opt_ch) $optarg
break
}
}
set argv [ lrange $argv $arg_idx end ]
return 0
}
#******************************************************************************
# getopt
#
# This function can be used to build getopts, but can also be used for
# different semantics, such as handling each occurrence of an option
# independently (e.g. "-a -a" handled differently than "-a").
#
# Parse the next option from argv and return it in optret and argret.
# Optstr is a string of valid option letters, with a colon following each
# non-boolean option letter (each option which takes an option argument).
#
# Options start with "-", except for the non-options "--", which is skipped
# over, and "-". Specifying the bundled option "-" is not allowed. Option
# processing terminates upon encountering the first non-option. Multiple
# options can be bundled into a single argument. The value of non-boolean
# options is taken from the remainder of the argument or the next argument
# if the remainder is empty.
#
# On error, argret contains an error message, optret contains the offending
# option, and -1 is returned. If no more options are found, 0 is returned
# and stateret(idx) contains the index of the first non-option.
#
# If an option is found, optret contains the option letter, argret contains
# the option value (1 for boolean options), and 1 is returned. The parsing
# state is returned in stateret, and should not be modified by the caller.
proc getopt { optstr argv stateret optret argret } {
upvar $stateret state
upvar $optret opt_ch
upvar $argret optarg
if { ! [ info exists state(idx) ]} {
set state(idx) 0
set state(idxc) 1
}
while { $state(idx) < [ llength $argv ]} {
set nextarg [ lindex $argv $state(idx) ]
if {[ string index $nextarg 0 ] != "-" } { return 0 }
if { $nextarg == "-" } { return 0 }
if { $nextarg == "--" } {
incr state(idx)
return 0
}
set opt_ch [ string index $nextarg $state(idxc) ]
if { $opt_ch == "" } {
incr state(idx)
set state(idxc) 1
continue
}
if { $opt_ch == "-" } {
set optarg "invalid option -"
return -1
}
incr state(idxc)
set pos [ string first $opt_ch $optstr ]
if { $pos < 0 || ( $opt_ch == ":" && $pos > 0 )} {
set optarg "invalid option $opt_ch"
return -1
}
if {[ string index $optstr [ incr pos ]] != ":" } {
set optarg 1
return 1
}
set optarg [ string range $nextarg $state(idxc) end ]
if { $optarg == "" } {
if {[ incr state(idx) ] >= [ llength $argv ]} {
set optarg "missing argument for option $opt_ch"
return -1
}
set optarg [ lindex $argv $state(idx) ]
}
incr state(idx)
set state(idxc) 1
return 1
}
return 0
}
#******************************************************************************
# getopts2 -- getopts layered on top of getopt
#
# Parse the options from argvret into the array optsret. Optstr is a string
# of valid option letters, with a colon following each non-boolean option
# letter (each option which takes an option argument).
#
# Options start with "-", except for the non-options "--", which is skipped
# over, and "-". Specifying the bundled option "-" is not allowed. Option
# processing terminates upon encountering the first non-option. Multiple
# options can be bundled into a single argument. The value of non-boolean
# options is taken from the remainder of the argument or the next argument
# if the remainder is empty.
#
# On error, argvret is not modified, optsret(error) contains an error
# message, optsret(opt) contains the offending option, and -1 is returned.
#
# On success, the parsed options are removed from argvret, optsret(error)
# and optsret(opt) contain an empty string, and 0 is returned. For each
# boolean option, the corresponding element of optsret is set to 0 (false)
# or 1 (true). For non-boolean options, the corresponding element of
# optsret contains whatever value was specified. For non-boolean options
# which are not specified, the corresponding element of optsret is not
# created and/or modified.
proc getopts2 { optstr argvret optsret } {
upvar $argvret argv
upvar $optsret opts
# initialize opts array with all boolean options set to 0 (false)
set opts(error) [ set opts(opt) "" ]
set opts_list [ split $optstr "" ]
for { set idx 0 } { $idx < [ llength $opts_list ] } { incr idx } {
if {[ lindex $opts_list [ expr $idx+1 ]] == ":" } {
incr idx
} else {
set opts([ lindex $opts_list $idx ]) 0
}
}
while {[ set rc [ getopt $optstr $argv state opt_ch optarg ]] > 0 } {
set opts($opt_ch) $optarg
}
if { $rc < 0 } {
set opts(error) $optarg
set opts(opt) $opt_ch
return -1
}
set argv [ lrange $argv $state(idx) end ]
return 0
}
#******************************************************************************
# define $prog and $usagemsg
set prog $::argv0
regsub {.*/} $prog "" prog
set usagemsg "
usage: $prog \[-ab] \[-o VAL] ARG...
-a option a
-b option b
-o VAL option o requires a value
"
regsub -all {\A\n|\n\Z} $usagemsg "" usagemsg ;# remove leading/trailing \n
#******************************************************************************
# usage message procedure, using $prog and $usagemsg
proc usage {{ msg "" }} {
global prog usagemsg
if { $msg != "" } { puts stderr "$prog: $msg" }
puts stderr $usagemsg
exit 1
}
#******************************************************************************
# run against actual script arguments with hardcoded dummy test options
if {[ getopts "?abo:" argv opts ] || $opts(?) } { usage $opts(error) }
#******************************************************************************
# run tests
proc array2list { arrname } {
upvar $arrname arr
foreach name [ lsort [ array names arr ]] {
lappend out $name $arr($name)
}
return $out
}
proc compare_versions { tag optstr argv_orig } {
global fail
set argv $argv_orig
array unset opts
set rc [ getopts $optstr argv opts ]
set out1 "rc:$rc opts:[ array2list opts ] args:$argv"
set argv $argv_orig
array unset opts
set rc [ getopts2 $optstr argv opts ]
set out2 "rc:$rc opts:[ array2list opts ] args:$argv"
if { $out1 == $out2 } { return }
set fail 1
puts "$tag mismatch orig argv:$argv_orig"
puts " out1=<$out1>"
puts " out2=<$out2>"
}
proc test_versions {} {
set cnt1 0
foreach optstr [ list \
"" \
"?" \
":" \
"?a" \
"?ao:" \
"?o:a" \
] {
incr cnt1
set cnt2 0
foreach argv [ list \
[ list ] \
[ list "?" ] \
[ list "-a-" ] \
[ list "-o" ] \
[ list "-o" "" ] \
[ list "-ao" ] \
[ list "-ao" "" ] \
[ list "-ao" "x" ] \
[ list "-a" "-ox" ] \
] {
incr cnt2
compare_versions "$cnt1/$cnt2" $optstr $argv
}
}
}
proc check_results {} {
global fail
set cnt1 0
foreach { optstr argv expected } [ list \
"" [ list ] \
"rc:0 opts:error {} opt {} args:" \
"" [ list fred ] \
"rc:0 opts:error {} opt {} args:fred" \
"" [ list - fred ] \
"rc:0 opts:error {} opt {} args:- fred" \
"" [ list : fred ] \
"rc:0 opts:error {} opt {} args:: fred" \
"" [ list -- fred ] \
"rc:0 opts:error {} opt {} args:fred" \
"?o:a" [ list -a- ] \
"rc:-1 opts:? 0 a 1 error {invalid option -} opt - args:-a-" \
"?o:a" [ list -ao fred ] \
"rc:0 opts:? 0 a 1 error {} o fred opt {} args:" \
"?o:a" [ list -a fred ] \
"rc:0 opts:? 0 a 1 error {} opt {} args:fred" \
"?o:a" [ list -a -o fred bob ] \
"rc:0 opts:? 0 a 1 error {} o fred opt {} args:bob" \
"?o:a" [ list -x fred ] \
"rc:-1 opts:? 0 a 0 error {invalid option x} opt x args:-x fred" \
"o:" [ list -o ] \
"rc:-1 opts:error {missing argument for option o} opt o args:-o" \
] {
array unset opts
set rc [ getopts $optstr argv opts ]
set actual "rc:$rc opts:[ array2list opts ] args:$argv"
if { $actual == $expected } { continue }
set fail 1
puts "Fail"
puts "actual: $actual"
puts "expected: $expected"
}
}
set fail 0
test_versions
check_results
if { $fail } {
puts stderr "Failed one or more tests"
exit 1
}
puts stderr "Success"
exit 0
#******************************************************************************
RFox - 2013-05-27 10:18:35http://tcllib.sourceforge.net/doc/cmdline.html
jrw32982 Here's the source for tcllib which includes cmdline.tcl: http://sourceforge.net/projects/tcllib/files/tcllib/
. However, cmdline.tcl is nothing like getopts, which is why I had to write getopts in the first place.