lib/newgetopt.pl

   1 # newgetopt.pl -- new options parsing
   2
   3 # SCCS Status     : @(#)@ newgetopt.pl  1.7
   4 # Author          : Johan Vromans
   5 # Created On      : Tue Sep 11 15:00:12 1990
   6 # Last Modified By: Johan Vromans
   7 # Last Modified On: Sun Oct 14 14:35:36 1990
   8 # Update Count    : 34
   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 #
  22 #  - if the first option of the list consists of non-alphanumeric
  23 #    characters only, it is interpreted as a generic option starter.
  24 #    Everything starting with one of the characters from the starter
  25 #    will be considered an option.
  26 #    Likewise, a double occurrence (e.g. "--") signals end of
  27 #    the options list.
  28 #    The default value for the starter is "-".
  29 #
  30 # Upon return, the option variables, prefixed with "opt_", are defined
  31 # and set to the respective option arguments, if any.
  32 # Options that do not take an argument are set to 1. Note that an
  33 # option with an optional argument will be defined, but set to '' if
  34 # no actual argument has been supplied.
  35 # A return status of 0 (false) indicates that the function detected
  36 # one or more errors.
  37 #
  38 # Special care is taken to give a correct treatment to optional arguments.
  39 #
  40 # E.g. if option "one:i" (i.e. takes an optional integer argument),
  41 # then the following situations are handled:
  42 #
  43 #    -one -two          -> $opt_one = '', -two is next option
  44 #    -one -2            -> $opt_one = -2
  45 #
  46 # Also, assume "foo=s" and "bar:s" :
  47 #
  48 #    -bar -xxx          -> $opt_bar = '', '-xxx' is next option
  49 #    -foo -bar          -> $opt_foo = '-bar'
  50 #    -foo --            -> $opt_foo = '--'
  51 #
  52
  53 # HISTORY
  54 # 20-Sep-1990           Johan Vromans
  55 #    Set options w/o argument to 1.
  56 #    Correct the dreadful semicolon/require bug.
  57
  58
  59 package newgetopt;
  60
  61 $debug = 0;                     # for debugging
  62
  63 sub main'NGetOpt {
  64     local (@optionlist) = @_;
  65     local ($[) = 0;
  66     local ($genprefix) = "-";
  67     local ($error) = 0;
  68     local ($opt, $optx, $arg, $type, $mand, @hits);
  69
  70     # See if the first element of the optionlist contains option
  71     # starter characters.
  72     $genprefix = shift (@optionlist) if $optionlist[0] =~ /^\W+$/;
  73
  74     # Turn into regexp.
  75     $genprefix =~ s/(\W)/\\\1/g;
  76     $genprefix = "[" . $genprefix . "]";
  77
  78     # Verify correctness of optionlist.
  79     @hits = grep ($_ !~ /^\w+([=:][infse])?$/, @optionlist);
  80     if ( $#hits >= 0 ) {
  81         foreach $opt ( @hits ) {
  82             print STDERR ("Error in option spec: \"", $opt, "\"\n");
  83             $error++;
  84         }
  85         return 0;
  86     }
  87
  88     # Process argument list
  89
  90     while ( $#main'ARGV >= 0 ) {                #'){
  91
  92         # >>> See also the continue block <<<
  93
  94         # Get next argument
  95         $opt = shift (@main'ARGV);              #');
  96         print STDERR ("=> option \"", $opt, "\"\n") if $debug;
  97         $arg = undef;
  98
  99         # Check for exhausted list.
 100         if ( $opt =~ /^$genprefix/o ) {
 101             # Double occurrence is terminator
 102             return ($error == 0) if $opt eq "$+$+";
 103             $opt = $';          # option name (w/o prefix)
 104         }
 105         else {
 106             # Apparently not an option - push back and exit.
 107             unshift (@main'ARGV, $opt);         #');
 108             return ($error == 0);
 109         }
 110
 111         # Grep in option list. Hide regexp chars from option.
 112         ($optx = $opt) =~ s/(\W)/\\\1/g;
 113         @hits = grep (/^$optx([=:].+)?$/, @optionlist);
 114         if ( $#hits != 0 ) {
 115             print STDERR ("Unknown option: ", $opt, "\n");
 116             $error++;
 117             next;
 118         }
 119
 120         # Determine argument status.
 121         undef $type;
 122         $type = $+ if $hits[0] =~ /[=:].+$/;
 123         print STDERR ("=> found \"$hits[0]\" for ", $opt, "\n") if $debug;
 124
 125         # If it is an option w/o argument, we're almost finished with it.
 126         if ( ! defined $type ) {
 127             $arg = 1;           # supply explicit value
 128             next;
 129         }
 130
 131         # Get mandatory status and type info.
 132         ($mand, $type) = $type =~ /^(.)(.)$/;
 133
 134         # Check if the argument list is exhausted.
 135         if ( $#main'ARGV < 0 ) {                #'){
 136
 137             # Complain if this option needs an argument.
 138             if ( $mand eq "=" ) {
 139                 print STDERR ("Option ", $opt, " requires an argument\n");
 140                 $error++;
 141             }
 142             next;
 143         }
 144
 145         # Get (possibly optional) argument.
 146         $arg = shift (@main'ARGV);              #');
 147
 148         # Check if it is a valid argument. A mandatory string takes
 149         # anything.
 150         if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/o ) {
 151
 152             # Check for option list terminator.
 153             if ( $arg eq "$+$+" ) {
 154                 # Complain if an argument is required.
 155                 if ($mand eq "=") {
 156                     print STDERR ("Option ", $opt, " requires an argument\n");
 157                     $error++;
 158                 }
 159                 # Push back so the outer loop will terminate.
 160                 unshift (@main'ARGV, $arg);     #');
 161                 $arg = "";      # don't assign it
 162                 next;
 163             }
 164
 165             # Maybe the optional argument is the next option?
 166             if ( $mand eq ":" && $' =~ /[a-zA-Z_]/ ) {
 167                 # Yep. Push back.
 168                 unshift (@main'ARGV, $arg);     #');
 169                 $arg = "";      # don't assign it
 170                 next;
 171             }
 172         }
 173
 174         if ( $type eq "n" || $type eq "i" ) { # numeric/integer
 175             if ( $arg !~ /^-?[0-9]+$/ ) {
 176                 print STDERR ("Value \"", $arg, "\" invalid for option ",
 177                                $opt, " (numeric required)\n");
 178                 $error++;
 179             }
 180             next;
 181         }
 182
 183         if ( $type eq "f" ) { # fixed real number, int is also ok
 184             if ( $arg !~ /^-?[0-9.]+$/ ) {
 185                 print STDERR ("Value \"", $arg, "\" invalid for option ",
 186                                $opt, " (real number required)\n");
 187                 $error++;
 188             }
 189             next;
 190         }
 191
 192         if ( $type eq "s" ) { # string
 193             next;
 194         }
 195
 196     }
 197     continue {
 198         print STDERR ("=> \$main'opt_$opt = $arg\n") if $debug;
 199         eval ("\$main'opt_$opt = \$arg");
 200     }
 201
 202     return ($error == 0);
 203 }
 204 1;