This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
beta3 File::Path warning fix
[perl5.git] / lib / Getopt / Long.pm
CommitLineData
a0d0e21e
LW
1package Getopt::Long;
2require 5.000;
3require Exporter;
4
5@ISA = qw(Exporter);
6@EXPORT = qw(GetOptions);
7
f06db76b
AD
8=head1 NAME
9
10GetOptions - extended getopt processing
11
12=head1 SYNOPSIS
13
14 use Getopt::Long;
15 $result = GetOptions (...option-descriptions...);
16
17=head1 DESCRIPTION
18
19The Getopt::Long module implements an extended getopt function called
20GetOptions(). This function adheres to the new syntax (long option names,
21no bundling). It tries to implement the better functionality of
22traditional, GNU and POSIX getopt() functions.
23
24Each description should designate a valid Perl identifier, optionally
25followed by an argument specifier.
26
27Values 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
35If option "name" is set, it will cause the Perl variable $opt_name to
36be set to the specified value. The calling program can use this
37variable to detect whether the option has been set. Options that do
38not take an argument will be set to 1 (one).
39
40Options that take an optional argument will be defined, but set to ''
41if no actual argument has been supplied.
42
43If an "@" sign is appended to the argument specifier, the option is
44treated as an array. Value(s) are not set, but pushed into array
45@opt_name.
46
47Options that do not take a value may have an "!" argument specifier to
48indicate that they may be negated. E.g. "foo!" will allow B<-foo> (which
49sets $opt_foo to 1) and B<-nofoo> (which will set $opt_foo to 0).
50
51The 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
55Option names may be abbreviated to uniqueness, depending on
56configuration variable $autoabbrev.
57
58Dashes in option names are allowed (e.g. pcc-struct-return) and will
59be translated to underscores in the corresponding Perl variable (e.g.
60$opt_pcc_struct_return). Note that a lone dash "-" is considered an
61option, corresponding Perl identifier is $opt_ .
62
63A double dash "--" signals end of the options list.
64
65If the first option of the list consists of non-alphanumeric
66characters only, it is interpreted as a generic option starter.
67Everything starting with one of the characters from the starter will
68be considered an option.
69
70The default values for the option starters are "-" (traditional), "--"
71(POSIX) and "+" (GNU, being phased out).
72
73Options that start with "--" may have an argument appended, separated
74with an "=", e.g. "--foo=bar".
75
76If configuration variable $getopt_compat is set to a non-zero value,
77options that start with "+" may also include their arguments,
78e.g. "+foo=bar".
79
80A return status of 0 (false) indicates that the function detected
81one or more errors.
82
83=head1 EXAMPLES
84
85If option "one:i" (i.e. takes an optional integer argument), then
86the following situations are handled:
87
88 -one -two -> $opt_one = '', -two is next option
89 -one -2 -> $opt_one = -2
90
91Also, 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
97In 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
107Allow option names to be abbreviated to uniqueness.
108Default is 1 unless environment variable
109POSIXLY_CORRECT has been set.
110
111=item $getopt_compat
112
113Allow '+' to start options.
114Default is 1 unless environment variable
115POSIXLY_CORRECT has been set.
116
117=item $option_start
118
119Regexp with option starters.
120Default is (--|-) if environment variable
121POSIXLY_CORRECT has been set, (--|-|\+) otherwise.
122
123=item $order
124
125Whether non-options are allowed to be mixed with
126options.
127Default is $REQUIRE_ORDER if environment variable
128POSIXLY_CORRECT has been set, $PERMUTE otherwise.
129
130=item $ignorecase
131
132Ignore case when matching options. Default is 1.
133
134=item $debug
135
136Enable debugging output. Default is 0.
137
138=back
139
f06db76b 140=cut
a0d0e21e
LW
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;
75f92628 339 $RETURN_IN_ORDER = 2; # avoid typo warning with -w
a0d0e21e
LW
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
363sub GetOptions {
364
365 @optionlist = @_; #';
366
367 local ($[) = 0;
368 local ($genprefix) = $option_start;
369 local ($argend) = $argv_end;
370 local ($error) = 0;
75f92628 371 local ($opt, $arg, $type, $mand, %opctl);
a0d0e21e
LW
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 ) {
f06db76b 452 unshift (@ARGV, @ret) if $order == $PERMUTE;
a0d0e21e
LW
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
6451;
646
647