This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
87824289615dbe7e4e093caf16e5ed3b78356201
[perl5.git] / lib / newgetopt.pl
1 # newgetopt.pl -- new options parsing
2
3 # SCCS Status     : @(#)@ newgetopt.pl  1.8
4 # Author          : Johan Vromans
5 # Created On      : Tue Sep 11 15:00:12 1990
6 # Last Modified By: Johan Vromans
7 # Last Modified On: Thu Sep 26 20:10:41 1991
8 # Update Count    : 35
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             if ( $mand eq ":" ) {
143                 $arg = $type eq "s" ? "" : 0;
144             }
145             next;
146         }
147
148         # Get (possibly optional) argument.
149         $arg = shift (@main'ARGV);              #');
150
151         # Check if it is a valid argument. A mandatory string takes
152         # anything. 
153         if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/o ) {
154
155             # Check for option list terminator.
156             if ( $arg eq "$+$+" ) {
157                 # Complain if an argument is required.
158                 if ($mand eq "=") {
159                     print STDERR ("Option ", $opt, " requires an argument\n");
160                     $error++;
161                 }
162                 # Push back so the outer loop will terminate.
163                 unshift (@main'ARGV, $arg);     #');
164                 $arg = "";      # don't assign it
165                 next;
166             }
167
168             # Maybe the optional argument is the next option?
169             if ( $mand eq ":" && $' =~ /[a-zA-Z_]/ ) {
170                 # Yep. Push back.
171                 unshift (@main'ARGV, $arg);     #');
172                 $arg = "";      # don't assign it
173                 next;
174             }
175         }
176
177         if ( $type eq "n" || $type eq "i" ) { # numeric/integer
178             if ( $arg !~ /^-?[0-9]+$/ ) {
179                 print STDERR ("Value \"", $arg, "\" invalid for option ",
180                                $opt, " (numeric required)\n");
181                 $error++;
182             }
183             next;
184         }
185
186         if ( $type eq "f" ) { # fixed real number, int is also ok
187             if ( $arg !~ /^-?[0-9.]+$/ ) {
188                 print STDERR ("Value \"", $arg, "\" invalid for option ",
189                                $opt, " (real number required)\n");
190                 $error++;
191             }
192             next;
193         }
194
195         if ( $type eq "s" ) { # string
196             next;
197         }
198
199     }
200     continue {
201         print STDERR ("=> \$main'opt_$opt = $arg\n") if $debug;
202         eval ("\$main'opt_$opt = \$arg");
203     }
204
205     return ($error == 0);
206 }
207 1;