perl5.002beta3
[perl.git] / lib / Getopt / Long.pm
1 package Getopt::Long;
2 require 5.000;
3 require Exporter;
4
5 @ISA = qw(Exporter);
6 @EXPORT = qw(GetOptions);
7
8 =head1 NAME
9
10 GetOptions - extended getopt processing
11
12 =head1 SYNOPSIS
13
14     use Getopt::Long;
15     $result = GetOptions (...option-descriptions...);
16
17 =head1 DESCRIPTION
18
19 The Getopt::Long module implements an extended getopt function called
20 GetOptions(). This function adheres to the new syntax (long option names,
21 no bundling).  It tries to implement the better functionality of
22 traditional, GNU and POSIX getopt() functions.
23
24 Each description should designate a valid Perl identifier, optionally
25 followed by an argument specifier.
26
27 Values for argument specifiers are:
28
29   <none>   option does not take an argument
30   !        option does not take an argument and may be negated
31   =s :s    option takes a mandatory (=) or optional (:) string argument
32   =i :i    option takes a mandatory (=) or optional (:) integer argument
33   =f :f    option takes a mandatory (=) or optional (:) real number argument
34
35 If option "name" is set, it will cause the Perl variable $opt_name to
36 be set to the specified value. The calling program can use this
37 variable to detect whether the option has been set. Options that do
38 not take an argument will be set to 1 (one).
39
40 Options that take an optional argument will be defined, but set to ''
41 if no actual argument has been supplied.
42
43 If an "@" sign is appended to the argument specifier, the option is
44 treated as an array.  Value(s) are not set, but pushed into array
45 @opt_name.
46
47 Options that do not take a value may have an "!" argument specifier to
48 indicate that they may be negated. E.g. "foo!" will allow B<-foo> (which
49 sets $opt_foo to 1) and B<-nofoo> (which will set $opt_foo to 0).
50
51 The option name may actually be a list of option names, separated by
52 '|'s, e.g. B<"foo|bar|blech=s". In this example, options 'bar' and
53 'blech' will set $opt_foo instead.
54
55 Option names may be abbreviated to uniqueness, depending on
56 configuration variable $autoabbrev.
57
58 Dashes in option names are allowed (e.g. pcc-struct-return) and will
59 be translated to underscores in the corresponding Perl variable (e.g.
60 $opt_pcc_struct_return).  Note that a lone dash "-" is considered an
61 option, corresponding Perl identifier is $opt_ .
62
63 A double dash "--" signals end of the options list.
64
65 If the first option of the list consists of non-alphanumeric
66 characters only, it is interpreted as a generic option starter.
67 Everything starting with one of the characters from the starter will
68 be considered an option.
69
70 The default values for the option starters are "-" (traditional), "--"
71 (POSIX) and "+" (GNU, being phased out).
72
73 Options that start with "--" may have an argument appended, separated
74 with an "=", e.g. "--foo=bar".
75
76 If configuration variable $getopt_compat is set to a non-zero value,
77 options that start with "+" may also include their arguments,
78 e.g. "+foo=bar".
79
80 A return status of 0 (false) indicates that the function detected
81 one or more errors.
82
83 =head1 EXAMPLES
84
85 If option "one:i" (i.e. takes an optional integer argument), then
86 the following situations are handled:
87
88    -one -two            -> $opt_one = '', -two is next option
89    -one -2              -> $opt_one = -2
90
91 Also, assume "foo=s" and "bar:s" :
92
93    -bar -xxx            -> $opt_bar = '', '-xxx' is next option
94    -foo -bar            -> $opt_foo = '-bar'
95    -foo --              -> $opt_foo = '--'
96
97 In GNU or POSIX format, option names and values can be combined:
98
99    +foo=blech           -> $opt_foo = 'blech'
100    --bar=               -> $opt_bar = ''
101    --bar=--             -> $opt_bar = '--'
102
103 =over 12
104
105 =item $autoabbrev      
106
107 Allow option names to be abbreviated to uniqueness.
108 Default is 1 unless environment variable
109 POSIXLY_CORRECT has been set.
110
111 =item $getopt_compat   
112
113 Allow '+' to start options.
114 Default is 1 unless environment variable
115 POSIXLY_CORRECT has been set.
116
117 =item $option_start    
118
119 Regexp with option starters.
120 Default is (--|-) if environment variable
121 POSIXLY_CORRECT has been set, (--|-|\+) otherwise.
122
123 =item $order           
124
125 Whether non-options are allowed to be mixed with
126 options.
127 Default is $REQUIRE_ORDER if environment variable
128 POSIXLY_CORRECT has been set, $PERMUTE otherwise.
129
130 =item $ignorecase      
131
132 Ignore case when matching options. Default is 1.
133
134 =item $debug           
135
136 Enable debugging output. Default is 0.
137
138 =back
139
140 =cut
141
142 # newgetopt.pl -- new options parsing
143
144 # SCCS Status     : @(#)@ newgetopt.pl  1.14
145 # Author          : Johan Vromans
146 # Created On      : Tue Sep 11 15:00:12 1990
147 # Last Modified By: Johan Vromans
148 # Last Modified On: Sat Feb 12 18:24:02 1994
149 # Update Count    : 138
150 # Status          : Okay
151
152 ################ Introduction ################
153 #
154 # This package implements an extended getopt function. This function adheres
155 # to the new syntax (long option names, no bundling).
156 # It tries to implement the better functionality of traditional, GNU and
157 # POSIX getopt functions.
158
159 # This program is Copyright 1990,1994 by Johan Vromans.
160 # This program is free software; you can redistribute it and/or
161 # modify it under the terms of the GNU General Public License
162 # as published by the Free Software Foundation; either version 2
163 # of the License, or (at your option) any later version.
164
165 # This program is distributed in the hope that it will be useful,
166 # but WITHOUT ANY WARRANTY; without even the implied warranty of
167 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
168 # GNU General Public License for more details.
169
170 # If you do not have a copy of the GNU General Public License write to
171 # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
172 # MA 02139, USA.
173
174 ################ Description ################
175 #
176 # Usage:
177
178 #    require "newgetopt.pl";
179 #    ...change configuration values, if needed...
180 #    $result = &NGetOpt (...option-descriptions...);
181
182 # Each description should designate a valid perl identifier, optionally
183 # followed by an argument specifier.
184
185 # Values for argument specifiers are:
186
187 #   <none>   option does not take an argument
188 #   !        option does not take an argument and may be negated
189 #   =s :s    option takes a mandatory (=) or optional (:) string argument
190 #   =i :i    option takes a mandatory (=) or optional (:) integer argument
191 #   =f :f    option takes a mandatory (=) or optional (:) real number argument
192
193 # If option "name" is set, it will cause the perl variable $opt_name to
194 # be set to the specified value. The calling program can use this
195 # variable to detect whether the option has been set. Options that do
196 # not take an argument will be set to 1 (one).
197
198 # Options that take an optional argument will be defined, but set to ''
199 # if no actual argument has been supplied.
200
201 # If an "@" sign is appended to the argument specifier, the option is
202 # treated as an array. Value(s) are not set, but pushed into array
203 # @opt_name.
204
205 # Options that do not take a value may have an "!" argument spacifier to
206 # indicate that they may be negated. E.g. "foo!" will allow -foo (which
207 # sets $opt_foo to 1) and -nofoo (which will set $opt_foo to 0).
208
209 # The option name may actually be a list of option names, separated by
210 # '|'s, e.g. "foo|bar|blech=s". In this example, options 'bar' and
211 # 'blech' will set $opt_foo instead.
212
213 # Option names may be abbreviated to uniqueness, depending on
214 # configuration variable $autoabbrev.
215
216 # Dashes in option names are allowed (e.g. pcc-struct-return) and will
217 # be translated to underscores in the corresponding perl variable (e.g.
218 # $opt_pcc_struct_return).  Note that a lone dash "-" is considered an
219 # option, corresponding perl identifier is $opt_ .
220
221 # A double dash "--" signals end of the options list.
222
223 # If the first option of the list consists of non-alphanumeric
224 # characters only, it is interpreted as a generic option starter.
225 # Everything starting with one of the characters from the starter will
226 # be considered an option.
227
228 # The default values for the option starters are "-" (traditional), "--"
229 # (POSIX) and "+" (GNU, being phased out).
230
231 # Options that start with "--" may have an argument appended, separated
232 # with an "=", e.g. "--foo=bar".
233
234 # If configuration varaible $getopt_compat is set to a non-zero value,
235 # options that start with "+" may also include their arguments,
236 # e.g. "+foo=bar".
237
238 # A return status of 0 (false) indicates that the function detected
239 # one or more errors.
240 #
241 ################ Some examples ################
242
243 # If option "one:i" (i.e. takes an optional integer argument), then
244 # the following situations are handled:
245
246 #    -one -two          -> $opt_one = '', -two is next option
247 #    -one -2            -> $opt_one = -2
248
249 # Also, assume "foo=s" and "bar:s" :
250
251 #    -bar -xxx          -> $opt_bar = '', '-xxx' is next option
252 #    -foo -bar          -> $opt_foo = '-bar'
253 #    -foo --            -> $opt_foo = '--'
254
255 # In GNU or POSIX format, option names and values can be combined:
256
257 #    +foo=blech         -> $opt_foo = 'blech'
258 #    --bar=             -> $opt_bar = ''
259 #    --bar=--           -> $opt_bar = '--'
260
261 ################ Configuration values ################
262
263 #   $autoabbrev      Allow option names to be abbreviated to uniqueness.
264 #                    Default is 1 unless environment variable
265 #                    POSIXLY_CORRECT has been set.
266
267 #   $getopt_compat   Allow '+' to start options.
268 #                    Default is 1 unless environment variable
269 #                    POSIXLY_CORRECT has been set.
270
271 #   $option_start    Regexp with option starters.
272 #                    Default is (--|-) if environment variable
273 #                    POSIXLY_CORRECT has been set, (--|-|\+) otherwise.
274
275 #   $order           Whether non-options are allowed to be mixed with
276 #                    options.
277 #                    Default is $REQUIRE_ORDER if environment variable
278 #                    POSIXLY_CORRECT has been set, $PERMUTE otherwise.
279
280 #   $ignorecase      Ignore case when matching options. Default is 1.
281
282 #   $debug           Enable debugging output. Default is 0.
283
284 ################ History ################
285
286 # 12-Feb-1994           Johan Vromans   
287 #    Added "!" for negation.
288 #    Released to the net.
289 #
290 # 26-Aug-1992           Johan Vromans   
291 #    More POSIX/GNU compliance.
292 #    Lone dash and double-dash are now independent of the option prefix
293 #      that is used.
294 #    Make errors in NGetOpt parameters fatal.
295 #    Allow options to be mixed with arguments.
296 #      Check $ENV{"POSIXLY_CORRECT"} to suppress this.
297 #    Allow --foo=bar and +foo=bar (but not -foo=bar).
298 #    Allow options to be abbreviated to minimum needed for uniqueness.
299 #      (Controlled by configuration variable $autoabbrev.)
300 #    Allow alias names for options (e.g. "foo|bar=s").
301 #    Allow "-" in option names (e.g. --pcc-struct-return). Dashes are
302 #      translated to "_" to form valid perl identifiers
303 #      (e.g. $opt_pcc_struct_return). 
304 #
305 # 2-Jun-1992            Johan Vromans   
306 #    Do not use //o to allow multiple NGetOpt calls with different delimeters.
307 #    Prevent typeless option from using previous $array state.
308 #    Prevent empty option from being eaten as a (negative) number.
309 #
310 # 25-May-1992           Johan Vromans   
311 #    Add array options. "foo=s@" will return an array @opt_foo that
312 #    contains all values that were supplied. E.g. "-foo one -foo -two" will
313 #    return @opt_foo = ("one", "-two");
314 #    Correct bug in handling options that allow for a argument when followed
315 #    by another option.
316 #
317 # 4-May-1992            Johan Vromans   
318 #    Add $ignorecase to match options in either case.
319 #    Allow '' option.
320 #
321 # 19-Mar-1992           Johan Vromans   
322 #    Allow require from packages.
323 #    NGetOpt is now defined in the package that requires it.
324 #    @ARGV and $opt_... are taken from the package that calls it.
325 #    Use standard (?) option prefixes: -, -- and +.
326 #
327 # 20-Sep-1990           Johan Vromans   
328 #    Set options w/o argument to 1.
329 #    Correct the dreadful semicolon/require bug.
330
331 ################ Configuration Section ################
332
333
334
335     # Values for $order. See GNU getopt.c for details.
336     $REQUIRE_ORDER = 0;
337     $PERMUTE = 1;
338     $RETURN_IN_ORDER = 2;
339     $RETURN_IN_ORDER = 2; # avoid typo warning with -w
340
341     # Handle POSIX compliancy.
342     if ( defined $ENV{"POSIXLY_CORRECT"} ) {
343         $autoabbrev = 0;        # no automatic abbrev of options (???)
344         $getopt_compat = 0;     # disallow '+' to start options
345         $option_start = "(--|-)";
346         $order = $REQUIRE_ORDER;
347     }
348     else {
349         $autoabbrev = 1;        # automatic abbrev of options
350         $getopt_compat = 1;     # allow '+' to start options
351         $option_start = "(--|-|\\+)";
352         $order = $PERMUTE;
353     }
354
355     # Other configurable settings.
356     $debug = 0;                 # for debugging
357     $ignorecase = 1;            # ignore case when matching options
358     $argv_end = "--";           # don't change this!
359 }
360
361 ################ Subroutines ################
362
363 sub GetOptions {
364
365     @optionlist = @_;   #';
366
367     local ($[) = 0;
368     local ($genprefix) = $option_start;
369     local ($argend) = $argv_end;
370     local ($error) = 0;
371     local ($opt, $arg, $type, $mand, %opctl);
372     local ($pkg) = (caller)[0];
373     local ($optarg);
374     local (%aliases);
375     local (@ret) = ();
376
377     print STDERR "NGetOpt 1.14 -- called from $pkg\n" if $debug;
378
379     # See if the first element of the optionlist contains option
380     # starter characters.
381     if ( $optionlist[0] =~ /^\W+$/ ) {
382         $genprefix = shift (@optionlist);
383         # Turn into regexp.
384         $genprefix =~ s/(\W)/\\$1/g;
385         $genprefix = "[" . $genprefix . "]";
386     }
387
388     # Verify correctness of optionlist.
389     %opctl = ();
390     foreach $opt ( @optionlist ) {
391         $opt =~ tr/A-Z/a-z/ if $ignorecase;
392         if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
393             die ("Error in option spec: \"", $opt, "\"\n");
394             $error++;
395             next;
396         }
397         local ($o, $c, $a) = ($1, $2);
398
399         if ( ! defined $o ) {
400             $opctl{''} = defined $c ? $c : '';
401         }
402         else {
403             # Handle alias names
404             foreach ( split (/\|/, $o)) {
405                 if ( defined $c && $c eq '!' ) {
406                     $opctl{"no$_"} = $c;
407                     $c = '';
408                 }
409                 $opctl{$_} = defined $c ? $c : '';
410                 if ( defined $a ) {
411                     # Note alias.
412                     $aliases{$_} = $a;
413                 }
414                 else {
415                     # Set primary name.
416                     $a = $_;
417                 }
418             }
419         }
420     }
421     @opctl = sort(keys (%opctl)) if $autoabbrev;
422
423     return 0 if $error;
424
425     if ( $debug ) {
426         local ($arrow, $k, $v);
427         $arrow = "=> ";
428         while ( ($k,$v) = each(%opctl) ) {
429             print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
430             $arrow = "   ";
431         }
432     }
433
434     # Process argument list
435
436     while ( $#ARGV >= 0 ) {
437
438         # >>> See also the continue block <<<
439
440         #### Get next argument ####
441
442         $opt = shift (@ARGV);
443         print STDERR ("=> option \"", $opt, "\"\n") if $debug;
444         $arg = undef;
445         $optarg = undef;
446         $array = 0;
447
448         #### Determine what we have ####
449
450         # Double dash is option list terminator.
451         if ( $opt eq $argend ) {
452             unshift (@ARGV, @ret) if $order == $PERMUTE;
453             return ($error == 0);
454         }
455         elsif ( $opt =~ /^$genprefix/ ) {
456             # Looks like an option.
457             $opt = $';          # option name (w/o prefix)
458             # If it is a long opt, it may include the value.
459             if (($+ eq "--" || ($getopt_compat && $+ eq "+")) && 
460                 $opt =~ /^([^=]+)=/ ) {
461                 $opt = $1;
462                 $optarg = $';
463                 print STDERR ("=> option \"", $opt, 
464                               "\", optarg = \"$optarg\"\n")
465                     if $debug;
466             }
467
468         }
469         # Not an option. Save it if we may permute...
470         elsif ( $order == $PERMUTE ) {
471             push (@ret, $opt);
472             next;
473         }
474         # ...otherwise, terminate.
475         else {
476             # Push back and exit.
477             unshift (@ARGV, $opt);
478             return ($error == 0);
479         }
480
481         #### Look it up ###
482
483         $opt =~ tr/A-Z/a-z/ if $ignorecase;
484
485         local ($tryopt) = $opt;
486         if ( $autoabbrev ) {
487             local ($pat, @hits);
488
489             # Turn option name into pattern.
490             ($pat = $opt) =~ s/(\W)/\\$1/g;
491             # Look up in option names.
492             @hits = grep (/^$pat/, @opctl);
493             print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ",
494                           "out of ", 0+@opctl, "\n")
495                 if $debug;
496
497             # Check for ambiguous results.
498             unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
499                 print STDERR ("Option ", $opt, " is ambiguous (",
500                               join(", ", @hits), ")\n");
501                 $error++;
502                 next;
503             }
504
505             # Complete the option name, if appropriate.
506             if ( @hits == 1 && $hits[0] ne $opt ) {
507                 $tryopt = $hits[0];
508                 print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
509                     if $debug;
510             }
511         }
512
513         unless  ( defined ( $type = $opctl{$tryopt} ) ) {
514             print STDERR ("Unknown option: ", $opt, "\n");
515             $error++;
516             next;
517         }
518         $opt = $tryopt;
519         print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
520
521         #### Determine argument status ####
522
523         # If it is an option w/o argument, we're almost finished with it.
524         if ( $type eq '' || $type eq '!' ) {
525             if ( defined $optarg ) {
526                 print STDERR ("Option ", $opt, " does not take an argument\n");
527                 $error++;
528             }
529             elsif ( $type eq '' ) {
530                 $arg = 1;               # supply explicit value
531             }
532             else {
533                 substr ($opt, 0, 2) = ''; # strip NO prefix
534                 $arg = 0;               # supply explicit value
535             }
536             next;
537         }
538
539         # Get mandatory status and type info.
540         ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
541
542         # Check if there is an option argument available.
543         if ( defined $optarg ? ($optarg eq '') : ($#ARGV < 0) ) {
544
545             # Complain if this option needs an argument.
546             if ( $mand eq "=" ) {
547                 print STDERR ("Option ", $opt, " requires an argument\n");
548                 $error++;
549             }
550             if ( $mand eq ":" ) {
551                 $arg = $type eq "s" ? '' : 0;
552             }
553             next;
554         }
555
556         # Get (possibly optional) argument.
557         $arg = defined $optarg ? $optarg : shift (@ARGV);
558
559         #### Check if the argument is valid for this option ####
560
561         if ( $type eq "s" ) {   # string
562             # A mandatory string takes anything. 
563             next if $mand eq "=";
564
565             # An optional string takes almost anything. 
566             next if defined $optarg;
567             next if $arg eq "-";
568
569             # Check for option or option list terminator.
570             if ($arg eq $argend ||
571                 $arg =~ /^$genprefix.+/) {
572                 # Push back.
573                 unshift (@ARGV, $arg);
574                 # Supply empty value.
575                 $arg = '';
576             }
577             next;
578         }
579
580         if ( $type eq "n" || $type eq "i" ) { # numeric/integer
581             if ( $arg !~ /^-?[0-9]+$/ ) {
582                 if ( defined $optarg || $mand eq "=" ) {
583                     print STDERR ("Value \"", $arg, "\" invalid for option ",
584                                   $opt, " (number expected)\n");
585                     $error++;
586                     undef $arg; # don't assign it
587                 }
588                 else {
589                     # Push back.
590                     unshift (@ARGV, $arg);
591                     # Supply default value.
592                     $arg = 0;
593                 }
594             }
595             next;
596         }
597
598         if ( $type eq "f" ) { # fixed real number, int is also ok
599             if ( $arg !~ /^-?[0-9.]+$/ ) {
600                 if ( defined $optarg || $mand eq "=" ) {
601                     print STDERR ("Value \"", $arg, "\" invalid for option ",
602                                   $opt, " (real number expected)\n");
603                     $error++;
604                     undef $arg; # don't assign it
605                 }
606                 else {
607                     # Push back.
608                     unshift (@ARGV, $arg);
609                     # Supply default value.
610                     $arg = 0.0;
611                 }
612             }
613             next;
614         }
615
616         die ("NGetOpt internal error (Can't happen)\n");
617     }
618
619     continue {
620         if ( defined $arg ) {
621             $opt = $aliases{$opt} if defined $aliases{$opt};
622             # Make sure a valid perl identifier results.
623             $opt =~ s/\W/_/g;
624             if ( $array ) {
625                 print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
626                     if $debug;
627                 eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
628             }
629             else {
630                 print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
631                     if $debug;
632                 eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
633             }
634         }
635     }
636
637     if ( $order == $PERMUTE && @ret > 0 ) {
638         unshift (@ARGV, @ret);
639     }
640     return ($error == 0);
641 }
642
643 ################ Package return ################
644
645 1;
646
647