Updated 2015-09-01 04:35:49 by pooryorick

jrw32982 Basic getopts processing which I couldn't find anywhere else, so I had to write myself. Two different versions. Test suite included.

The first version of getopts is sufficient for most needs and mirrors what is available in shell and perl's Getopt::Std.

The second version of getopts consists of two functions. The lower function getopt allows for each option to be processed independently in whatever way the caller chooses. The upper function (getopts2) implements exactly the same interface as getopts, but making use of the lower function (getopt).
#!/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:35

http://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.