This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 4.0 patch 28: patch #20, continued
[perl5.git] / 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;