#!/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

#******************************************************************************