lib/newgetopt.pl

   1 # newgetopt.pl -- new options parsing
   2
   3 # SCCS Status     : @(#)@ newgetopt.pl  1.13
   4 # Author          : Johan Vromans
   5 # Created On      : Tue Sep 11 15:00:12 1990
   6 # Last Modified By: Johan Vromans
   7 # Last Modified On: Tue Jun  2 11:24:03 1992
   8 # Update Count    : 75
   9 # Status          : Okay
  10
  11 # This package implements a new getopt function. This function adheres
  12 # to the new syntax (long option names, no bundling).
  13 #
  14 # Arguments to the function are:
  15 #
  16 #  - a list of possible options. These should designate valid perl
  17 #    identifiers, optionally followed by an argument specifier ("="
  18 #    for mandatory arguments or ":" for optional arguments) and an
  19 #    argument type specifier: "n" or "i" for integer numbers, "f" for
  20 #    real (fix) numbers or "s" for strings.
  21 #    If an "@" sign is appended, the option is treated as an array.
  22 #    Value(s) are not set, but pushed.
  23 #
  24 #  - if the first option of the list consists of non-alphanumeric
  25 #    characters only, it is interpreted as a generic option starter.
  26 #    Everything starting with one of the characters from the starter
  27 #    will be considered an option.
  28 #    Likewise, a double occurrence (e.g. "--") signals end of
  29 #    the options list.
  30 #    The default value for the starter is "-", "--" or "+".
  31 #
  32 # Upon return, the option variables, prefixed with "opt_", are defined
  33 # and set to the respective option arguments, if any.
  34 # Options that do not take an argument are set to 1. Note that an
  35 # option with an optional argument will be defined, but set to '' if
  36 # no actual argument has been supplied.
  37 # A return status of 0 (false) indicates that the function detected
  38 # one or more errors.
  39 #
  40 # Special care is taken to give a correct treatment to optional arguments.
  41 #
  42 # E.g. if option "one:i" (i.e. takes an optional integer argument),
  43 # then the following situations are handled:
  44 #
  45 #    -one -two          -> $opt_one = '', -two is next option
  46 #    -one -2            -> $opt_one = -2
  47 #
  48 # Also, assume "foo=s" and "bar:s" :
  49 #
  50 #    -bar -xxx          -> $opt_bar = '', '-xxx' is next option
  51 #    -foo -bar          -> $opt_foo = '-bar'
  52 #    -foo --            -> $opt_foo = '--'
  53 #
  54 # HISTORY
  55 # 2-Jun-1992            Johan Vromans
  56 #    Do not use //o to allow multiple NGetOpt calls with different delimeters.
  57 #    Prevent typeless option from using previous $array state.
  58 #    Prevent empty option from being eaten as a (negative) number.
  59
  60 # 25-May-1992           Johan Vromans
  61 #    Add array options. "foo=s@" will return an array @opt_foo that
  62 #    contains all values that were supplied. E.g. "-foo one -foo -two" will
  63 #    return @opt_foo = ("one", "-two");
  64 #    Correct bug in handling options that allow for a argument when followed
  65 #    by another option.
  66
  67 # 4-May-1992            Johan Vromans
  68 #    Add $ignorecase to match options in either case.
  69 #    Allow '' option.
  70
  71 # 19-Mar-1992           Johan Vromans
  72 #    Allow require from packages.
  73 #    NGetOpt is now defined in the package that requires it.
  74 #    @ARGV and $opt_... are taken from the package that calls it.
  75 #    Use standard (?) option prefixes: -, -- and +.
  76
  77 # 20-Sep-1990           Johan Vromans
  78 #    Set options w/o argument to 1.
  79 #    Correct the dreadful semicolon/require bug.
  80
  81
  82 {   package newgetopt;
  83     $debug = 0;                 # for debugging
  84     $ignorecase = 1;            # ignore case when matching options
  85 }
  86
  87 sub NGetOpt {
  88
  89     @newgetopt'optionlist = @_;
  90     *newgetopt'ARGV = *ARGV;
  91
  92     package newgetopt;
  93
  94     local ($[) = 0;
  95     local ($genprefix) = "(--|-|\\+)";
  96     local ($argend) = "--";
  97     local ($error) = 0;
  98     local ($opt, $optx, $arg, $type, $mand, %opctl);
  99     local ($pkg) = (caller)[0];
 100
 101     print STDERR "NGetOpt 1.13 -- called from $pkg\n" if $debug;
 102
 103     # See if the first element of the optionlist contains option
 104     # starter characters.
 105     if ( $optionlist[0] =~ /^\W+$/ ) {
 106         $genprefix = shift (@optionlist);
 107         # Turn into regexp.
 108         $genprefix =~ s/(\W)/\\\1/g;
 109         $genprefix = "[" . $genprefix . "]";
 110         undef $argend;
 111     }
 112
 113     # Verify correctness of optionlist.
 114     %opctl = ();
 115     foreach $opt ( @optionlist ) {
 116         $opt =~ tr/A-Z/a-z/ if $ignorecase;
 117         if ( $opt !~ /^(\w*)([=:][infse]@?)?$/ ) {
 118             print STDERR ("Error in option spec: \"", $opt, "\"\n");
 119             $error++;
 120             next;
 121         }
 122         $opctl{$1} = defined $2 ? $2 : "";
 123     }
 124
 125     return 0 if $error;
 126
 127     if ( $debug ) {
 128         local ($arrow, $k, $v);
 129         $arrow = "=> ";
 130         while ( ($k,$v) = each(%opctl) ) {
 131             print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
 132             $arrow = "   ";
 133         }
 134     }
 135
 136     # Process argument list
 137
 138     while ( $#ARGV >= 0 ) {
 139
 140         # >>> See also the continue block <<<
 141
 142         # Get next argument
 143         $opt = shift (@ARGV);
 144         print STDERR ("=> option \"", $opt, "\"\n") if $debug;
 145         $arg = undef;
 146
 147         # Check for exhausted list.
 148         if ( $opt =~ /^$genprefix/ ) {
 149             # Double occurrence is terminator
 150             return ($error == 0)
 151                 if ($opt eq "$+$+") || ((defined $argend) && $opt eq $argend);
 152             $opt = $';          # option name (w/o prefix)
 153         }
 154         else {
 155             # Apparently not an option - push back and exit.
 156             unshift (@ARGV, $opt);
 157             return ($error == 0);
 158         }
 159
 160         # Look it up.
 161         $opt =~ tr/A-Z/a-z/ if $ignorecase;
 162         unless  ( defined ( $type = $opctl{$opt} ) ) {
 163             print STDERR ("Unknown option: ", $opt, "\n");
 164             $error++;
 165             next;
 166         }
 167
 168         # Determine argument status.
 169         print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
 170
 171         # If it is an option w/o argument, we're almost finished with it.
 172         if ( $type eq "" ) {
 173             $arg = 1;           # supply explicit value
 174             $array = 0;
 175             next;
 176         }
 177
 178         # Get mandatory status and type info.
 179         ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
 180
 181         # Check if the argument list is exhausted.
 182         if ( $#ARGV < 0 ) {
 183
 184             # Complain if this option needs an argument.
 185             if ( $mand eq "=" ) {
 186                 print STDERR ("Option ", $opt, " requires an argument\n");
 187                 $error++;
 188             }
 189             if ( $mand eq ":" ) {
 190                 $arg = $type eq "s" ? "" : 0;
 191             }
 192             next;
 193         }
 194
 195         # Get (possibly optional) argument.
 196         $arg = shift (@ARGV);
 197
 198         # Check if it is a valid argument. A mandatory string takes
 199         # anything.
 200         if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/ ) {
 201
 202             # Check for option list terminator.
 203             if ( $arg eq "$+$+" ||
 204                  ((defined $argend) && $arg eq $argend)) {
 205                 # Push back so the outer loop will terminate.
 206                 unshift (@ARGV, $arg);
 207                 # Complain if an argument is required.
 208                 if ($mand eq "=") {
 209                     print STDERR ("Option ", $opt, " requires an argument\n");
 210                     $error++;
 211                     undef $arg; # don't assign it
 212                 }
 213                 else {
 214                     # Supply empty value.
 215                     $arg = $type eq "s" ? "" : 0;
 216                 }
 217                 next;
 218             }
 219
 220             # Maybe the optional argument is the next option?
 221             if ( $mand eq ":" && ($' eq "" || $' =~ /[a-zA-Z_]/) ) {
 222                 # Yep. Push back.
 223                 unshift (@ARGV, $arg);
 224                 $arg = $type eq "s" ? "" : 0;
 225                 next;
 226             }
 227         }
 228
 229         if ( $type eq "n" || $type eq "i" ) { # numeric/integer
 230             if ( $arg !~ /^-?[0-9]+$/ ) {
 231                 print STDERR ("Value \"", $arg, "\" invalid for option ",
 232                               $opt, " (number expected)\n");
 233                 $error++;
 234                 undef $arg;     # don't assign it
 235             }
 236             next;
 237         }
 238
 239         if ( $type eq "f" ) { # fixed real number, int is also ok
 240             if ( $arg !~ /^-?[0-9.]+$/ ) {
 241                 print STDERR ("Value \"", $arg, "\" invalid for option ",
 242                               $opt, " (real number expected)\n");
 243                 $error++;
 244                 undef $arg;     # don't assign it
 245             }
 246             next;
 247         }
 248
 249         if ( $type eq "s" ) { # string
 250             next;
 251         }
 252
 253     }
 254     continue {
 255         if ( defined $arg ) {
 256             if ( $array ) {
 257                 print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
 258                     if $debug;
 259                 eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
 260             }
 261             else {
 262                 print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
 263                     if $debug;
 264                 eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
 265             }
 266         }
 267     }
 268
 269     return ($error == 0);
 270 }
 271 1;