This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
98c215d6b6a435f95de204e0306c00bc7c714ab8
[perl5.git] / cpan / Getopt-Long / lib / Getopt / Long.pm
1 #! perl
2
3 # Getopt::Long.pm -- Universal options parsing
4 # Author          : Johan Vromans
5 # Created On      : Tue Sep 11 15:00:12 1990
6 # Last Modified By: Johan Vromans
7 # Last Modified On: Mon Jul  8 08:22:51 2013
8 # Update Count    : 1644
9 # Status          : Released
10
11 ################ Module Preamble ################
12
13 package Getopt::Long;
14
15 use 5.004;
16
17 use strict;
18
19 use vars qw($VERSION);
20 $VERSION        =  2.41;
21 # For testing versions only.
22 use vars qw($VERSION_STRING);
23 $VERSION_STRING = "2.41";
24
25 use Exporter;
26 use vars qw(@ISA @EXPORT @EXPORT_OK);
27 @ISA = qw(Exporter);
28
29 # Exported subroutines.
30 sub GetOptions(@);              # always
31 sub GetOptionsFromArray(@);     # on demand
32 sub GetOptionsFromString(@);    # on demand
33 sub Configure(@);               # on demand
34 sub HelpMessage(@);             # on demand
35 sub VersionMessage(@);          # in demand
36
37 BEGIN {
38     # Init immediately so their contents can be used in the 'use vars' below.
39     @EXPORT    = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
40     @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure
41                     &GetOptionsFromArray &GetOptionsFromString);
42 }
43
44 # User visible variables.
45 use vars @EXPORT, @EXPORT_OK;
46 use vars qw($error $debug $major_version $minor_version);
47 # Deprecated visible variables.
48 use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
49             $passthrough);
50 # Official invisible variables.
51 use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);
52
53 # Public subroutines.
54 sub config(@);                  # deprecated name
55
56 # Private subroutines.
57 sub ConfigDefaults();
58 sub ParseOptionSpec($$);
59 sub OptCtl($);
60 sub FindOption($$$$$);
61 sub ValidValue ($$$$$);
62
63 ################ Local Variables ################
64
65 # $requested_version holds the version that was mentioned in the 'use'
66 # or 'require', if any. It can be used to enable or disable specific
67 # features.
68 my $requested_version = 0;
69
70 ################ Resident subroutines ################
71
72 sub ConfigDefaults() {
73     # Handle POSIX compliancy.
74     if ( defined $ENV{"POSIXLY_CORRECT"} ) {
75         $genprefix = "(--|-)";
76         $autoabbrev = 0;                # no automatic abbrev of options
77         $bundling = 0;                  # no bundling of single letter switches
78         $getopt_compat = 0;             # disallow '+' to start options
79         $order = $REQUIRE_ORDER;
80     }
81     else {
82         $genprefix = "(--|-|\\+)";
83         $autoabbrev = 1;                # automatic abbrev of options
84         $bundling = 0;                  # bundling off by default
85         $getopt_compat = 1;             # allow '+' to start options
86         $order = $PERMUTE;
87     }
88     # Other configurable settings.
89     $debug = 0;                 # for debugging
90     $error = 0;                 # error tally
91     $ignorecase = 1;            # ignore case when matching options
92     $passthrough = 0;           # leave unrecognized options alone
93     $gnu_compat = 0;            # require --opt=val if value is optional
94     $longprefix = "(--)";       # what does a long prefix look like
95 }
96
97 # Override import.
98 sub import {
99     my $pkg = shift;            # package
100     my @syms = ();              # symbols to import
101     my @config = ();            # configuration
102     my $dest = \@syms;          # symbols first
103     for ( @_ ) {
104         if ( $_ eq ':config' ) {
105             $dest = \@config;   # config next
106             next;
107         }
108         push(@$dest, $_);       # push
109     }
110     # Hide one level and call super.
111     local $Exporter::ExportLevel = 1;
112     push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions
113     $requested_version = 0;
114     $pkg->SUPER::import(@syms);
115     # And configure.
116     Configure(@config) if @config;
117 }
118
119 ################ Initialization ################
120
121 # Values for $order. See GNU getopt.c for details.
122 ($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
123 # Version major/minor numbers.
124 ($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
125
126 ConfigDefaults();
127
128 ################ OO Interface ################
129
130 package Getopt::Long::Parser;
131
132 # Store a copy of the default configuration. Since ConfigDefaults has
133 # just been called, what we get from Configure is the default.
134 my $default_config = do {
135     Getopt::Long::Configure ()
136 };
137
138 sub new {
139     my $that = shift;
140     my $class = ref($that) || $that;
141     my %atts = @_;
142
143     # Register the callers package.
144     my $self = { caller_pkg => (caller)[0] };
145
146     bless ($self, $class);
147
148     # Process config attributes.
149     if ( defined $atts{config} ) {
150         my $save = Getopt::Long::Configure ($default_config, @{$atts{config}});
151         $self->{settings} = Getopt::Long::Configure ($save);
152         delete ($atts{config});
153     }
154     # Else use default config.
155     else {
156         $self->{settings} = $default_config;
157     }
158
159     if ( %atts ) {              # Oops
160         die(__PACKAGE__.": unhandled attributes: ".
161             join(" ", sort(keys(%atts)))."\n");
162     }
163
164     $self;
165 }
166
167 sub configure {
168     my ($self) = shift;
169
170     # Restore settings, merge new settings in.
171     my $save = Getopt::Long::Configure ($self->{settings}, @_);
172
173     # Restore orig config and save the new config.
174     $self->{settings} = Getopt::Long::Configure ($save);
175 }
176
177 sub getoptions {
178     my ($self) = shift;
179
180     return $self->getoptionsfromarray(\@ARGV, @_);
181 }
182
183 sub getoptionsfromarray {
184     my ($self) = shift;
185
186     # Restore config settings.
187     my $save = Getopt::Long::Configure ($self->{settings});
188
189     # Call main routine.
190     my $ret = 0;
191     $Getopt::Long::caller = $self->{caller_pkg};
192
193     eval {
194         # Locally set exception handler to default, otherwise it will
195         # be called implicitly here, and again explicitly when we try
196         # to deliver the messages.
197         local ($SIG{__DIE__}) = 'DEFAULT';
198         $ret = Getopt::Long::GetOptionsFromArray (@_);
199     };
200
201     # Restore saved settings.
202     Getopt::Long::Configure ($save);
203
204     # Handle errors and return value.
205     die ($@) if $@;
206     return $ret;
207 }
208
209 package Getopt::Long;
210
211 ################ Back to Normal ################
212
213 # Indices in option control info.
214 # Note that ParseOptions uses the fields directly. Search for 'hard-wired'.
215 use constant CTL_TYPE    => 0;
216 #use constant   CTL_TYPE_FLAG   => '';
217 #use constant   CTL_TYPE_NEG    => '!';
218 #use constant   CTL_TYPE_INCR   => '+';
219 #use constant   CTL_TYPE_INT    => 'i';
220 #use constant   CTL_TYPE_INTINC => 'I';
221 #use constant   CTL_TYPE_XINT   => 'o';
222 #use constant   CTL_TYPE_FLOAT  => 'f';
223 #use constant   CTL_TYPE_STRING => 's';
224
225 use constant CTL_CNAME   => 1;
226
227 use constant CTL_DEFAULT => 2;
228
229 use constant CTL_DEST    => 3;
230  use constant   CTL_DEST_SCALAR => 0;
231  use constant   CTL_DEST_ARRAY  => 1;
232  use constant   CTL_DEST_HASH   => 2;
233  use constant   CTL_DEST_CODE   => 3;
234
235 use constant CTL_AMIN    => 4;
236 use constant CTL_AMAX    => 5;
237
238 # FFU.
239 #use constant CTL_RANGE   => ;
240 #use constant CTL_REPEAT  => ;
241
242 # Rather liberal patterns to match numbers.
243 use constant PAT_INT   => "[-+]?_*[0-9][0-9_]*";
244 use constant PAT_XINT  =>
245   "(?:".
246           "[-+]?_*[1-9][0-9_]*".
247   "|".
248           "0x_*[0-9a-f][0-9a-f_]*".
249   "|".
250           "0b_*[01][01_]*".
251   "|".
252           "0[0-7_]*".
253   ")";
254 use constant PAT_FLOAT => "[-+]?[0-9._]+(\.[0-9_]+)?([eE][-+]?[0-9_]+)?";
255
256 sub GetOptions(@) {
257     # Shift in default array.
258     unshift(@_, \@ARGV);
259     # Try to keep caller() and Carp consistent.
260     goto &GetOptionsFromArray;
261 }
262
263 sub GetOptionsFromString(@) {
264     my ($string) = shift;
265     require Text::ParseWords;
266     my $args = [ Text::ParseWords::shellwords($string) ];
267     $caller ||= (caller)[0];    # current context
268     my $ret = GetOptionsFromArray($args, @_);
269     return ( $ret, $args ) if wantarray;
270     if ( @$args ) {
271         $ret = 0;
272         warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
273     }
274     $ret;
275 }
276
277 sub GetOptionsFromArray(@) {
278
279     my ($argv, @optionlist) = @_;       # local copy of the option descriptions
280     my $argend = '--';          # option list terminator
281     my %opctl = ();             # table of option specs
282     my $pkg = $caller || (caller)[0];   # current context
283                                 # Needed if linkage is omitted.
284     my @ret = ();               # accum for non-options
285     my %linkage;                # linkage
286     my $userlinkage;            # user supplied HASH
287     my $opt;                    # current option
288     my $prefix = $genprefix;    # current prefix
289
290     $error = '';
291
292     if ( $debug ) {
293         # Avoid some warnings if debugging.
294         local ($^W) = 0;
295         print STDERR
296           ("Getopt::Long $Getopt::Long::VERSION ",
297            "called from package \"$pkg\".",
298            "\n  ",
299            "argv: (@$argv)",
300            "\n  ",
301            "autoabbrev=$autoabbrev,".
302            "bundling=$bundling,",
303            "getopt_compat=$getopt_compat,",
304            "gnu_compat=$gnu_compat,",
305            "order=$order,",
306            "\n  ",
307            "ignorecase=$ignorecase,",
308            "requested_version=$requested_version,",
309            "passthrough=$passthrough,",
310            "genprefix=\"$genprefix\",",
311            "longprefix=\"$longprefix\".",
312            "\n");
313     }
314
315     # Check for ref HASH as first argument.
316     # First argument may be an object. It's OK to use this as long
317     # as it is really a hash underneath.
318     $userlinkage = undef;
319     if ( @optionlist && ref($optionlist[0]) and
320          UNIVERSAL::isa($optionlist[0],'HASH') ) {
321         $userlinkage = shift (@optionlist);
322         print STDERR ("=> user linkage: $userlinkage\n") if $debug;
323     }
324
325     # See if the first element of the optionlist contains option
326     # starter characters.
327     # Be careful not to interpret '<>' as option starters.
328     if ( @optionlist && $optionlist[0] =~ /^\W+$/
329          && !($optionlist[0] eq '<>'
330               && @optionlist > 0
331               && ref($optionlist[1])) ) {
332         $prefix = shift (@optionlist);
333         # Turn into regexp. Needs to be parenthesized!
334         $prefix =~ s/(\W)/\\$1/g;
335         $prefix = "([" . $prefix . "])";
336         print STDERR ("=> prefix=\"$prefix\"\n") if $debug;
337     }
338
339     # Verify correctness of optionlist.
340     %opctl = ();
341     while ( @optionlist ) {
342         my $opt = shift (@optionlist);
343
344         unless ( defined($opt) ) {
345             $error .= "Undefined argument in option spec\n";
346             next;
347         }
348
349         # Strip leading prefix so people can specify "--foo=i" if they like.
350         $opt = $+ if $opt =~ /^$prefix+(.*)$/s;
351
352         if ( $opt eq '<>' ) {
353             if ( (defined $userlinkage)
354                 && !(@optionlist > 0 && ref($optionlist[0]))
355                 && (exists $userlinkage->{$opt})
356                 && ref($userlinkage->{$opt}) ) {
357                 unshift (@optionlist, $userlinkage->{$opt});
358             }
359             unless ( @optionlist > 0
360                     && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
361                 $error .= "Option spec <> requires a reference to a subroutine\n";
362                 # Kill the linkage (to avoid another error).
363                 shift (@optionlist)
364                   if @optionlist && ref($optionlist[0]);
365                 next;
366             }
367             $linkage{'<>'} = shift (@optionlist);
368             next;
369         }
370
371         # Parse option spec.
372         my ($name, $orig) = ParseOptionSpec ($opt, \%opctl);
373         unless ( defined $name ) {
374             # Failed. $orig contains the error message. Sorry for the abuse.
375             $error .= $orig;
376             # Kill the linkage (to avoid another error).
377             shift (@optionlist)
378               if @optionlist && ref($optionlist[0]);
379             next;
380         }
381
382         # If no linkage is supplied in the @optionlist, copy it from
383         # the userlinkage if available.
384         if ( defined $userlinkage ) {
385             unless ( @optionlist > 0 && ref($optionlist[0]) ) {
386                 if ( exists $userlinkage->{$orig} &&
387                      ref($userlinkage->{$orig}) ) {
388                     print STDERR ("=> found userlinkage for \"$orig\": ",
389                                   "$userlinkage->{$orig}\n")
390                         if $debug;
391                     unshift (@optionlist, $userlinkage->{$orig});
392                 }
393                 else {
394                     # Do nothing. Being undefined will be handled later.
395                     next;
396                 }
397             }
398         }
399
400         # Copy the linkage. If omitted, link to global variable.
401         if ( @optionlist > 0 && ref($optionlist[0]) ) {
402             print STDERR ("=> link \"$orig\" to $optionlist[0]\n")
403                 if $debug;
404             my $rl = ref($linkage{$orig} = shift (@optionlist));
405
406             if ( $rl eq "ARRAY" ) {
407                 $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY;
408             }
409             elsif ( $rl eq "HASH" ) {
410                 $opctl{$name}[CTL_DEST] = CTL_DEST_HASH;
411             }
412             elsif ( $rl eq "SCALAR" || $rl eq "REF" ) {
413 #               if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
414 #                   my $t = $linkage{$orig};
415 #                   $$t = $linkage{$orig} = [];
416 #               }
417 #               elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
418 #               }
419 #               else {
420                     # Ok.
421 #               }
422             }
423             elsif ( $rl eq "CODE" ) {
424                 # Ok.
425             }
426             else {
427                 $error .= "Invalid option linkage for \"$opt\"\n";
428             }
429         }
430         else {
431             # Link to global $opt_XXX variable.
432             # Make sure a valid perl identifier results.
433             my $ov = $orig;
434             $ov =~ s/\W/_/g;
435             if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
436                 print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n")
437                     if $debug;
438                 eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;");
439             }
440             elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
441                 print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n")
442                     if $debug;
443                 eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;");
444             }
445             else {
446                 print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n")
447                     if $debug;
448                 eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;");
449             }
450         }
451
452         if ( $opctl{$name}[CTL_TYPE] eq 'I'
453              && ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY
454                   || $opctl{$name}[CTL_DEST] == CTL_DEST_HASH )
455            ) {
456             $error .= "Invalid option linkage for \"$opt\"\n";
457         }
458
459     }
460
461     # Bail out if errors found.
462     die ($error) if $error;
463     $error = 0;
464
465     # Supply --version and --help support, if needed and allowed.
466     if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) {
467         if ( !defined($opctl{version}) ) {
468             $opctl{version} = ['','version',0,CTL_DEST_CODE,undef];
469             $linkage{version} = \&VersionMessage;
470         }
471         $auto_version = 1;
472     }
473     if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) {
474         if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) {
475             $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef];
476             $linkage{help} = \&HelpMessage;
477         }
478         $auto_help = 1;
479     }
480
481     # Show the options tables if debugging.
482     if ( $debug ) {
483         my ($arrow, $k, $v);
484         $arrow = "=> ";
485         while ( ($k,$v) = each(%opctl) ) {
486             print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n");
487             $arrow = "   ";
488         }
489     }
490
491     # Process argument list
492     my $goon = 1;
493     while ( $goon && @$argv > 0 ) {
494
495         # Get next argument.
496         $opt = shift (@$argv);
497         print STDERR ("=> arg \"", $opt, "\"\n") if $debug;
498
499         # Double dash is option list terminator.
500         if ( defined($opt) && $opt eq $argend ) {
501           push (@ret, $argend) if $passthrough;
502           last;
503         }
504
505         # Look it up.
506         my $tryopt = $opt;
507         my $found;              # success status
508         my $key;                # key (if hash type)
509         my $arg;                # option argument
510         my $ctl;                # the opctl entry
511
512         ($found, $opt, $ctl, $arg, $key) =
513           FindOption ($argv, $prefix, $argend, $opt, \%opctl);
514
515         if ( $found ) {
516
517             # FindOption undefines $opt in case of errors.
518             next unless defined $opt;
519
520             my $argcnt = 0;
521             while ( defined $arg ) {
522
523                 # Get the canonical name.
524                 print STDERR ("=> cname for \"$opt\" is ") if $debug;
525                 $opt = $ctl->[CTL_CNAME];
526                 print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug;
527
528                 if ( defined $linkage{$opt} ) {
529                     print STDERR ("=> ref(\$L{$opt}) -> ",
530                                   ref($linkage{$opt}), "\n") if $debug;
531
532                     if ( ref($linkage{$opt}) eq 'SCALAR'
533                          || ref($linkage{$opt}) eq 'REF' ) {
534                         if ( $ctl->[CTL_TYPE] eq '+' ) {
535                             print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
536                               if $debug;
537                             if ( defined ${$linkage{$opt}} ) {
538                                 ${$linkage{$opt}} += $arg;
539                             }
540                             else {
541                                 ${$linkage{$opt}} = $arg;
542                             }
543                         }
544                         elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
545                             print STDERR ("=> ref(\$L{$opt}) auto-vivified",
546                                           " to ARRAY\n")
547                               if $debug;
548                             my $t = $linkage{$opt};
549                             $$t = $linkage{$opt} = [];
550                             print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
551                               if $debug;
552                             push (@{$linkage{$opt}}, $arg);
553                         }
554                         elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
555                             print STDERR ("=> ref(\$L{$opt}) auto-vivified",
556                                           " to HASH\n")
557                               if $debug;
558                             my $t = $linkage{$opt};
559                             $$t = $linkage{$opt} = {};
560                             print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
561                               if $debug;
562                             $linkage{$opt}->{$key} = $arg;
563                         }
564                         else {
565                             print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
566                               if $debug;
567                             ${$linkage{$opt}} = $arg;
568                         }
569                     }
570                     elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
571                         print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
572                             if $debug;
573                         push (@{$linkage{$opt}}, $arg);
574                     }
575                     elsif ( ref($linkage{$opt}) eq 'HASH' ) {
576                         print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
577                             if $debug;
578                         $linkage{$opt}->{$key} = $arg;
579                     }
580                     elsif ( ref($linkage{$opt}) eq 'CODE' ) {
581                         print STDERR ("=> &L{$opt}(\"$opt\"",
582                                       $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
583                                       ", \"$arg\")\n")
584                             if $debug;
585                         my $eval_error = do {
586                             local $@;
587                             local $SIG{__DIE__}  = 'DEFAULT';
588                             eval {
589                                 &{$linkage{$opt}}
590                                   (Getopt::Long::CallBack->new
591                                    (name    => $opt,
592                                     ctl     => $ctl,
593                                     opctl   => \%opctl,
594                                     linkage => \%linkage,
595                                     prefix  => $prefix,
596                                    ),
597                                    $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
598                                    $arg);
599                             };
600                             $@;
601                         };
602                         print STDERR ("=> die($eval_error)\n")
603                           if $debug && $eval_error ne '';
604                         if ( $eval_error =~ /^!/ ) {
605                             if ( $eval_error =~ /^!FINISH\b/ ) {
606                                 $goon = 0;
607                             }
608                         }
609                         elsif ( $eval_error ne '' ) {
610                             warn ($eval_error);
611                             $error++;
612                         }
613                     }
614                     else {
615                         print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
616                                       "\" in linkage\n");
617                         die("Getopt::Long -- internal error!\n");
618                     }
619                 }
620                 # No entry in linkage means entry in userlinkage.
621                 elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
622                     if ( defined $userlinkage->{$opt} ) {
623                         print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
624                             if $debug;
625                         push (@{$userlinkage->{$opt}}, $arg);
626                     }
627                     else {
628                         print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
629                             if $debug;
630                         $userlinkage->{$opt} = [$arg];
631                     }
632                 }
633                 elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
634                     if ( defined $userlinkage->{$opt} ) {
635                         print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
636                             if $debug;
637                         $userlinkage->{$opt}->{$key} = $arg;
638                     }
639                     else {
640                         print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
641                             if $debug;
642                         $userlinkage->{$opt} = {$key => $arg};
643                     }
644                 }
645                 else {
646                     if ( $ctl->[CTL_TYPE] eq '+' ) {
647                         print STDERR ("=> \$L{$opt} += \"$arg\"\n")
648                           if $debug;
649                         if ( defined $userlinkage->{$opt} ) {
650                             $userlinkage->{$opt} += $arg;
651                         }
652                         else {
653                             $userlinkage->{$opt} = $arg;
654                         }
655                     }
656                     else {
657                         print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
658                         $userlinkage->{$opt} = $arg;
659                     }
660                 }
661
662                 $argcnt++;
663                 last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
664                 undef($arg);
665
666                 # Need more args?
667                 if ( $argcnt < $ctl->[CTL_AMIN] ) {
668                     if ( @$argv ) {
669                         if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) {
670                             $arg = shift(@$argv);
671                             if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) {
672                                 $arg =~ tr/_//d;
673                                 $arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/
674                                   ? oct($arg)
675                                   : 0+$arg
676                             }
677                             ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
678                               if $ctl->[CTL_DEST] == CTL_DEST_HASH;
679                             next;
680                         }
681                         warn("Value \"$$argv[0]\" invalid for option $opt\n");
682                         $error++;
683                     }
684                     else {
685                         warn("Insufficient arguments for option $opt\n");
686                         $error++;
687                     }
688                 }
689
690                 # Any more args?
691                 if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) {
692                     $arg = shift(@$argv);
693                     if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) {
694                         $arg =~ tr/_//d;
695                         $arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/
696                           ? oct($arg)
697                           : 0+$arg
698                     }
699                     ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
700                       if $ctl->[CTL_DEST] == CTL_DEST_HASH;
701                     next;
702                 }
703             }
704         }
705
706         # Not an option. Save it if we $PERMUTE and don't have a <>.
707         elsif ( $order == $PERMUTE ) {
708             # Try non-options call-back.
709             my $cb;
710             if ( (defined ($cb = $linkage{'<>'})) ) {
711                 print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
712                   if $debug;
713                 my $eval_error = do {
714                     local $@;
715                     local $SIG{__DIE__}  = 'DEFAULT';
716                     eval {
717                         # The arg to <> cannot be the CallBack object
718                         # since it may be passed to other modules that
719                         # get confused (e.g., Archive::Tar). Well,
720                         # it's not relevant for this callback anyway.
721                         &$cb($tryopt);
722                     };
723                     $@;
724                 };
725                 print STDERR ("=> die($eval_error)\n")
726                   if $debug && $eval_error ne '';
727                 if ( $eval_error =~ /^!/ ) {
728                     if ( $eval_error =~ /^!FINISH\b/ ) {
729                         $goon = 0;
730                     }
731                 }
732                 elsif ( $eval_error ne '' ) {
733                     warn ($eval_error);
734                     $error++;
735                 }
736             }
737             else {
738                 print STDERR ("=> saving \"$tryopt\" ",
739                               "(not an option, may permute)\n") if $debug;
740                 push (@ret, $tryopt);
741             }
742             next;
743         }
744
745         # ...otherwise, terminate.
746         else {
747             # Push this one back and exit.
748             unshift (@$argv, $tryopt);
749             return ($error == 0);
750         }
751
752     }
753
754     # Finish.
755     if ( @ret && $order == $PERMUTE ) {
756         #  Push back accumulated arguments
757         print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
758             if $debug;
759         unshift (@$argv, @ret);
760     }
761
762     return ($error == 0);
763 }
764
765 # A readable representation of what's in an optbl.
766 sub OptCtl ($) {
767     my ($v) = @_;
768     my @v = map { defined($_) ? ($_) : ("<undef>") } @$v;
769     "[".
770       join(",",
771            "\"$v[CTL_TYPE]\"",
772            "\"$v[CTL_CNAME]\"",
773            "\"$v[CTL_DEFAULT]\"",
774            ("\$","\@","\%","\&")[$v[CTL_DEST] || 0],
775            $v[CTL_AMIN] || '',
776            $v[CTL_AMAX] || '',
777 #          $v[CTL_RANGE] || '',
778 #          $v[CTL_REPEAT] || '',
779           ). "]";
780 }
781
782 # Parse an option specification and fill the tables.
783 sub ParseOptionSpec ($$) {
784     my ($opt, $opctl) = @_;
785
786     # Match option spec.
787     if ( $opt !~ m;^
788                    (
789                      # Option name
790                      (?: \w+[-\w]* )
791                      # Alias names, or "?"
792                      (?: \| (?: \? | \w[-\w]* ) )*
793                      # Aliases
794                      (?: \| (?: [^-|!+=:][^|!+=:]* )? )*
795                    )?
796                    (
797                      # Either modifiers ...
798                      [!+]
799                      |
800                      # ... or a value/dest/repeat specification
801                      [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
802                      |
803                      # ... or an optional-with-default spec
804                      : (?: -?\d+ | \+ ) [@%]?
805                    )?
806                    $;x ) {
807         return (undef, "Error in option spec: \"$opt\"\n");
808     }
809
810     my ($names, $spec) = ($1, $2);
811     $spec = '' unless defined $spec;
812
813     # $orig keeps track of the primary name the user specified.
814     # This name will be used for the internal or external linkage.
815     # In other words, if the user specifies "FoO|BaR", it will
816     # match any case combinations of 'foo' and 'bar', but if a global
817     # variable needs to be set, it will be $opt_FoO in the exact case
818     # as specified.
819     my $orig;
820
821     my @names;
822     if ( defined $names ) {
823         @names =  split (/\|/, $names);
824         $orig = $names[0];
825     }
826     else {
827         @names = ('');
828         $orig = '';
829     }
830
831     # Construct the opctl entries.
832     my $entry;
833     if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
834         # Fields are hard-wired here.
835         $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0];
836     }
837     elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) {
838         my $def = $1;
839         my $dest = $2;
840         my $type = $def eq '+' ? 'I' : 'i';
841         $dest ||= '$';
842         $dest = $dest eq '@' ? CTL_DEST_ARRAY
843           : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
844         # Fields are hard-wired here.
845         $entry = [$type,$orig,$def eq '+' ? undef : $def,
846                   $dest,0,1];
847     }
848     else {
849         my ($mand, $type, $dest) =
850           $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
851         return (undef, "Cannot repeat while bundling: \"$opt\"\n")
852           if $bundling && defined($4);
853         my ($mi, $cm, $ma) = ($5, $6, $7);
854         return (undef, "{0} is useless in option spec: \"$opt\"\n")
855           if defined($mi) && !$mi && !defined($ma) && !defined($cm);
856
857         $type = 'i' if $type eq 'n';
858         $dest ||= '$';
859         $dest = $dest eq '@' ? CTL_DEST_ARRAY
860           : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
861         # Default minargs to 1/0 depending on mand status.
862         $mi = $mand eq '=' ? 1 : 0 unless defined $mi;
863         # Adjust mand status according to minargs.
864         $mand = $mi ? '=' : ':';
865         # Adjust maxargs.
866         $ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
867         return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
868           if defined($ma) && !$ma;
869         return (undef, "Max less than min in option spec: \"$opt\"\n")
870           if defined($ma) && $ma < $mi;
871
872         # Fields are hard-wired here.
873         $entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
874     }
875
876     # Process all names. First is canonical, the rest are aliases.
877     my $dups = '';
878     foreach ( @names ) {
879
880         $_ = lc ($_)
881           if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
882
883         if ( exists $opctl->{$_} ) {
884             $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
885         }
886
887         if ( $spec eq '!' ) {
888             $opctl->{"no$_"} = $entry;
889             $opctl->{"no-$_"} = $entry;
890             $opctl->{$_} = [@$entry];
891             $opctl->{$_}->[CTL_TYPE] = '';
892         }
893         else {
894             $opctl->{$_} = $entry;
895         }
896     }
897
898     if ( $dups && $^W ) {
899         foreach ( split(/\n+/, $dups) ) {
900             warn($_."\n");
901         }
902     }
903     ($names[0], $orig);
904 }
905
906 # Option lookup.
907 sub FindOption ($$$$$) {
908
909     # returns (1, $opt, $ctl, $arg, $key) if okay,
910     # returns (1, undef) if option in error,
911     # returns (0) otherwise.
912
913     my ($argv, $prefix, $argend, $opt, $opctl) = @_;
914
915     print STDERR ("=> find \"$opt\"\n") if $debug;
916
917     return (0) unless defined($opt);
918     return (0) unless $opt =~ /^($prefix)(.*)$/s;
919     return (0) if $opt eq "-" && !defined $opctl->{''};
920
921     $opt = substr( $opt, length($1) ); # retain taintedness
922     my $starter = $1;
923
924     print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
925
926     my $optarg;                 # value supplied with --opt=value
927     my $rest;                   # remainder from unbundling
928
929     # If it is a long option, it may include the value.
930     # With getopt_compat, only if not bundling.
931     if ( ($starter=~/^$longprefix$/
932           || ($getopt_compat && ($bundling == 0 || $bundling == 2)))
933          && (my $oppos = index($opt, '=', 1)) > 0) {
934         my $optorg = $opt;
935         $opt = substr($optorg, 0, $oppos);
936         $optarg = substr($optorg, $oppos + 1); # retain tainedness
937         print STDERR ("=> option \"", $opt,
938                       "\", optarg = \"$optarg\"\n") if $debug;
939     }
940
941     #### Look it up ###
942
943     my $tryopt = $opt;          # option to try
944
945     if ( $bundling && $starter eq '-' ) {
946
947         # To try overrides, obey case ignore.
948         $tryopt = $ignorecase ? lc($opt) : $opt;
949
950         # If bundling == 2, long options can override bundles.
951         if ( $bundling == 2 && length($tryopt) > 1
952              && defined ($opctl->{$tryopt}) ) {
953             print STDERR ("=> $starter$tryopt overrides unbundling\n")
954               if $debug;
955         }
956         else {
957             $tryopt = $opt;
958             # Unbundle single letter option.
959             $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
960             $tryopt = substr ($tryopt, 0, 1);
961             $tryopt = lc ($tryopt) if $ignorecase > 1;
962             print STDERR ("=> $starter$tryopt unbundled from ",
963                           "$starter$tryopt$rest\n") if $debug;
964             $rest = undef unless $rest ne '';
965         }
966     }
967
968     # Try auto-abbreviation.
969     elsif ( $autoabbrev && $opt ne "" ) {
970         # Sort the possible long option names.
971         my @names = sort(keys (%$opctl));
972         # Downcase if allowed.
973         $opt = lc ($opt) if $ignorecase;
974         $tryopt = $opt;
975         # Turn option name into pattern.
976         my $pat = quotemeta ($opt);
977         # Look up in option names.
978         my @hits = grep (/^$pat/, @names);
979         print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
980                       "out of ", scalar(@names), "\n") if $debug;
981
982         # Check for ambiguous results.
983         unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
984             # See if all matches are for the same option.
985             my %hit;
986             foreach ( @hits ) {
987                 my $hit = $opctl->{$_}->[CTL_CNAME]
988                   if defined $opctl->{$_}->[CTL_CNAME];
989                 $hit = "no" . $hit if $opctl->{$_}->[CTL_TYPE] eq '!';
990                 $hit{$hit} = 1;
991             }
992             # Remove auto-supplied options (version, help).
993             if ( keys(%hit) == 2 ) {
994                 if ( $auto_version && exists($hit{version}) ) {
995                     delete $hit{version};
996                 }
997                 elsif ( $auto_help && exists($hit{help}) ) {
998                     delete $hit{help};
999                 }
1000             }
1001             # Now see if it really is ambiguous.
1002             unless ( keys(%hit) == 1 ) {
1003                 return (0) if $passthrough;
1004                 warn ("Option ", $opt, " is ambiguous (",
1005                       join(", ", @hits), ")\n");
1006                 $error++;
1007                 return (1, undef);
1008             }
1009             @hits = keys(%hit);
1010         }
1011
1012         # Complete the option name, if appropriate.
1013         if ( @hits == 1 && $hits[0] ne $opt ) {
1014             $tryopt = $hits[0];
1015             $tryopt = lc ($tryopt) if $ignorecase;
1016             print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
1017                 if $debug;
1018         }
1019     }
1020
1021     # Map to all lowercase if ignoring case.
1022     elsif ( $ignorecase ) {
1023         $tryopt = lc ($opt);
1024     }
1025
1026     # Check validity by fetching the info.
1027     my $ctl = $opctl->{$tryopt};
1028     unless  ( defined $ctl ) {
1029         return (0) if $passthrough;
1030         # Pretend one char when bundling.
1031         if ( $bundling == 1 && length($starter) == 1 ) {
1032             $opt = substr($opt,0,1);
1033             unshift (@$argv, $starter.$rest) if defined $rest;
1034         }
1035         if ( $opt eq "" ) {
1036             warn ("Missing option after ", $starter, "\n");
1037         }
1038         else {
1039             warn ("Unknown option: ", $opt, "\n");
1040         }
1041         $error++;
1042         return (1, undef);
1043     }
1044     # Apparently valid.
1045     $opt = $tryopt;
1046     print STDERR ("=> found ", OptCtl($ctl),
1047                   " for \"", $opt, "\"\n") if $debug;
1048
1049     #### Determine argument status ####
1050
1051     # If it is an option w/o argument, we're almost finished with it.
1052     my $type = $ctl->[CTL_TYPE];
1053     my $arg;
1054
1055     if ( $type eq '' || $type eq '!' || $type eq '+' ) {
1056         if ( defined $optarg ) {
1057             return (0) if $passthrough;
1058             warn ("Option ", $opt, " does not take an argument\n");
1059             $error++;
1060             undef $opt;
1061         }
1062         elsif ( $type eq '' || $type eq '+' ) {
1063             # Supply explicit value.
1064             $arg = 1;
1065         }
1066         else {
1067             $opt =~ s/^no-?//i; # strip NO prefix
1068             $arg = 0;           # supply explicit value
1069         }
1070         unshift (@$argv, $starter.$rest) if defined $rest;
1071         return (1, $opt, $ctl, $arg);
1072     }
1073
1074     # Get mandatory status and type info.
1075     my $mand = $ctl->[CTL_AMIN];
1076
1077     # Check if there is an option argument available.
1078     if ( $gnu_compat && defined $optarg && $optarg eq '' ) {
1079         return (1, $opt, $ctl, $type eq 's' ? '' : 0) ;#unless $mand;
1080         $optarg = 0 unless $type eq 's';
1081     }
1082
1083     # Check if there is an option argument available.
1084     if ( defined $optarg
1085          ? ($optarg eq '')
1086          : !(defined $rest || @$argv > 0) ) {
1087         # Complain if this option needs an argument.
1088 #       if ( $mand && !($type eq 's' ? defined($optarg) : 0) ) {
1089         if ( $mand ) {
1090             return (0) if $passthrough;
1091             warn ("Option ", $opt, " requires an argument\n");
1092             $error++;
1093             return (1, undef);
1094         }
1095         if ( $type eq 'I' ) {
1096             # Fake incremental type.
1097             my @c = @$ctl;
1098             $c[CTL_TYPE] = '+';
1099             return (1, $opt, \@c, 1);
1100         }
1101         return (1, $opt, $ctl,
1102                 defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1103                 $type eq 's' ? '' : 0);
1104     }
1105
1106     # Get (possibly optional) argument.
1107     $arg = (defined $rest ? $rest
1108             : (defined $optarg ? $optarg : shift (@$argv)));
1109
1110     # Get key if this is a "name=value" pair for a hash option.
1111     my $key;
1112     if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
1113         ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
1114           : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1115              ($mand ? undef : ($type eq 's' ? "" : 1)));
1116         if (! defined $arg) {
1117             warn ("Option $opt, key \"$key\", requires a value\n");
1118             $error++;
1119             # Push back.
1120             unshift (@$argv, $starter.$rest) if defined $rest;
1121             return (1, undef);
1122         }
1123     }
1124
1125     #### Check if the argument is valid for this option ####
1126
1127     my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
1128
1129     if ( $type eq 's' ) {       # string
1130         # A mandatory string takes anything.
1131         return (1, $opt, $ctl, $arg, $key) if $mand;
1132
1133         # Same for optional string as a hash value
1134         return (1, $opt, $ctl, $arg, $key)
1135           if $ctl->[CTL_DEST] == CTL_DEST_HASH;
1136
1137         # An optional string takes almost anything.
1138         return (1, $opt, $ctl, $arg, $key)
1139           if defined $optarg || defined $rest;
1140         return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
1141
1142         # Check for option or option list terminator.
1143         if ($arg eq $argend ||
1144             $arg =~ /^$prefix.+/) {
1145             # Push back.
1146             unshift (@$argv, $arg);
1147             # Supply empty value.
1148             $arg = '';
1149         }
1150     }
1151
1152     elsif ( $type eq 'i'        # numeric/integer
1153             || $type eq 'I'     # numeric/integer w/ incr default
1154             || $type eq 'o' ) { # dec/oct/hex/bin value
1155
1156         my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
1157
1158         if ( $bundling && defined $rest
1159              && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
1160             ($key, $arg, $rest) = ($1, $2, $+);
1161             chop($key) if $key;
1162             $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
1163             unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
1164         }
1165         elsif ( $arg =~ /^$o_valid$/si ) {
1166             $arg =~ tr/_//d;
1167             $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
1168         }
1169         else {
1170             if ( defined $optarg || $mand ) {
1171                 if ( $passthrough ) {
1172                     unshift (@$argv, defined $rest ? $starter.$rest : $arg)
1173                       unless defined $optarg;
1174                     return (0);
1175                 }
1176                 warn ("Value \"", $arg, "\" invalid for option ",
1177                       $opt, " (",
1178                       $type eq 'o' ? "extended " : '',
1179                       "number expected)\n");
1180                 $error++;
1181                 # Push back.
1182                 unshift (@$argv, $starter.$rest) if defined $rest;
1183                 return (1, undef);
1184             }
1185             else {
1186                 # Push back.
1187                 unshift (@$argv, defined $rest ? $starter.$rest : $arg);
1188                 if ( $type eq 'I' ) {
1189                     # Fake incremental type.
1190                     my @c = @$ctl;
1191                     $c[CTL_TYPE] = '+';
1192                     return (1, $opt, \@c, 1);
1193                 }
1194                 # Supply default value.
1195                 $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
1196             }
1197         }
1198     }
1199
1200     elsif ( $type eq 'f' ) { # real number, int is also ok
1201         # We require at least one digit before a point or 'e',
1202         # and at least one digit following the point and 'e'.
1203         # [-]NN[.NN][eNN]
1204         my $o_valid = PAT_FLOAT;
1205         if ( $bundling && defined $rest &&
1206              $rest =~ /^($key_valid)($o_valid)(.*)$/s ) {
1207             $arg =~ tr/_//d;
1208             ($key, $arg, $rest) = ($1, $2, $+);
1209             chop($key) if $key;
1210             unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
1211         }
1212         elsif ( $arg =~ /^$o_valid$/ ) {
1213             $arg =~ tr/_//d;
1214         }
1215         else {
1216             if ( defined $optarg || $mand ) {
1217                 if ( $passthrough ) {
1218                     unshift (@$argv, defined $rest ? $starter.$rest : $arg)
1219                       unless defined $optarg;
1220                     return (0);
1221                 }
1222                 warn ("Value \"", $arg, "\" invalid for option ",
1223                       $opt, " (real number expected)\n");
1224                 $error++;
1225                 # Push back.
1226                 unshift (@$argv, $starter.$rest) if defined $rest;
1227                 return (1, undef);
1228             }
1229             else {
1230                 # Push back.
1231                 unshift (@$argv, defined $rest ? $starter.$rest : $arg);
1232                 # Supply default value.
1233                 $arg = 0.0;
1234             }
1235         }
1236     }
1237     else {
1238         die("Getopt::Long internal error (Can't happen)\n");
1239     }
1240     return (1, $opt, $ctl, $arg, $key);
1241 }
1242
1243 sub ValidValue ($$$$$) {
1244     my ($ctl, $arg, $mand, $argend, $prefix) = @_;
1245
1246     if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
1247         return 0 unless $arg =~ /[^=]+=(.*)/;
1248         $arg = $1;
1249     }
1250
1251     my $type = $ctl->[CTL_TYPE];
1252
1253     if ( $type eq 's' ) {       # string
1254         # A mandatory string takes anything.
1255         return (1) if $mand;
1256
1257         return (1) if $arg eq "-";
1258
1259         # Check for option or option list terminator.
1260         return 0 if $arg eq $argend || $arg =~ /^$prefix.+/;
1261         return 1;
1262     }
1263
1264     elsif ( $type eq 'i'        # numeric/integer
1265             || $type eq 'I'     # numeric/integer w/ incr default
1266             || $type eq 'o' ) { # dec/oct/hex/bin value
1267
1268         my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
1269         return $arg =~ /^$o_valid$/si;
1270     }
1271
1272     elsif ( $type eq 'f' ) { # real number, int is also ok
1273         # We require at least one digit before a point or 'e',
1274         # and at least one digit following the point and 'e'.
1275         # [-]NN[.NN][eNN]
1276         my $o_valid = PAT_FLOAT;
1277         return $arg =~ /^$o_valid$/;
1278     }
1279     die("ValidValue: Cannot happen\n");
1280 }
1281
1282 # Getopt::Long Configuration.
1283 sub Configure (@) {
1284     my (@options) = @_;
1285
1286     my $prevconfig =
1287       [ $error, $debug, $major_version, $minor_version,
1288         $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
1289         $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
1290         $longprefix ];
1291
1292     if ( ref($options[0]) eq 'ARRAY' ) {
1293         ( $error, $debug, $major_version, $minor_version,
1294           $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
1295           $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
1296           $longprefix ) = @{shift(@options)};
1297     }
1298
1299     my $opt;
1300     foreach $opt ( @options ) {
1301         my $try = lc ($opt);
1302         my $action = 1;
1303         if ( $try =~ /^no_?(.*)$/s ) {
1304             $action = 0;
1305             $try = $+;
1306         }
1307         if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
1308             ConfigDefaults ();
1309         }
1310         elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
1311             local $ENV{POSIXLY_CORRECT};
1312             $ENV{POSIXLY_CORRECT} = 1 if $action;
1313             ConfigDefaults ();
1314         }
1315         elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
1316             $autoabbrev = $action;
1317         }
1318         elsif ( $try eq 'getopt_compat' ) {
1319             $getopt_compat = $action;
1320             $genprefix = $action ? "(--|-|\\+)" : "(--|-)";
1321         }
1322         elsif ( $try eq 'gnu_getopt' ) {
1323             if ( $action ) {
1324                 $gnu_compat = 1;
1325                 $bundling = 1;
1326                 $getopt_compat = 0;
1327                 $genprefix = "(--|-)";
1328                 $order = $PERMUTE;
1329             }
1330         }
1331         elsif ( $try eq 'gnu_compat' ) {
1332             $gnu_compat = $action;
1333         }
1334         elsif ( $try =~ /^(auto_?)?version$/ ) {
1335             $auto_version = $action;
1336         }
1337         elsif ( $try =~ /^(auto_?)?help$/ ) {
1338             $auto_help = $action;
1339         }
1340         elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
1341             $ignorecase = $action;
1342         }
1343         elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) {
1344             $ignorecase = $action ? 2 : 0;
1345         }
1346         elsif ( $try eq 'bundling' ) {
1347             $bundling = $action;
1348         }
1349         elsif ( $try eq 'bundling_override' ) {
1350             $bundling = $action ? 2 : 0;
1351         }
1352         elsif ( $try eq 'require_order' ) {
1353             $order = $action ? $REQUIRE_ORDER : $PERMUTE;
1354         }
1355         elsif ( $try eq 'permute' ) {
1356             $order = $action ? $PERMUTE : $REQUIRE_ORDER;
1357         }
1358         elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
1359             $passthrough = $action;
1360         }
1361         elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
1362             $genprefix = $1;
1363             # Turn into regexp. Needs to be parenthesized!
1364             $genprefix = "(" . quotemeta($genprefix) . ")";
1365             eval { '' =~ /$genprefix/; };
1366             die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@;
1367         }
1368         elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
1369             $genprefix = $1;
1370             # Parenthesize if needed.
1371             $genprefix = "(" . $genprefix . ")"
1372               unless $genprefix =~ /^\(.*\)$/;
1373             eval { '' =~ m"$genprefix"; };
1374             die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@;
1375         }
1376         elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) {
1377             $longprefix = $1;
1378             # Parenthesize if needed.
1379             $longprefix = "(" . $longprefix . ")"
1380               unless $longprefix =~ /^\(.*\)$/;
1381             eval { '' =~ m"$longprefix"; };
1382             die("Getopt::Long: invalid long prefix pattern \"$longprefix\"\n") if $@;
1383         }
1384         elsif ( $try eq 'debug' ) {
1385             $debug = $action;
1386         }
1387         else {
1388             die("Getopt::Long: unknown or erroneous config parameter \"$opt\"\n")
1389         }
1390     }
1391     $prevconfig;
1392 }
1393
1394 # Deprecated name.
1395 sub config (@) {
1396     Configure (@_);
1397 }
1398
1399 # Issue a standard message for --version.
1400 #
1401 # The arguments are mostly the same as for Pod::Usage::pod2usage:
1402 #
1403 #  - a number (exit value)
1404 #  - a string (lead in message)
1405 #  - a hash with options. See Pod::Usage for details.
1406 #
1407 sub VersionMessage(@) {
1408     # Massage args.
1409     my $pa = setup_pa_args("version", @_);
1410
1411     my $v = $main::VERSION;
1412     my $fh = $pa->{-output} ||
1413       ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR;
1414
1415     print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
1416                $0, defined $v ? " version $v" : (),
1417                "\n",
1418                "(", __PACKAGE__, "::", "GetOptions",
1419                " version ",
1420                defined($Getopt::Long::VERSION_STRING)
1421                  ? $Getopt::Long::VERSION_STRING : $VERSION, ";",
1422                " Perl version ",
1423                $] >= 5.006 ? sprintf("%vd", $^V) : $],
1424                ")\n");
1425     exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT";
1426 }
1427
1428 # Issue a standard message for --help.
1429 #
1430 # The arguments are the same as for Pod::Usage::pod2usage:
1431 #
1432 #  - a number (exit value)
1433 #  - a string (lead in message)
1434 #  - a hash with options. See Pod::Usage for details.
1435 #
1436 sub HelpMessage(@) {
1437     eval {
1438         require Pod::Usage;
1439         import Pod::Usage;
1440         1;
1441     } || die("Cannot provide help: cannot load Pod::Usage\n");
1442
1443     # Note that pod2usage will issue a warning if -exitval => NOEXIT.
1444     pod2usage(setup_pa_args("help", @_));
1445
1446 }
1447
1448 # Helper routine to set up a normalized hash ref to be used as
1449 # argument to pod2usage.
1450 sub setup_pa_args($@) {
1451     my $tag = shift;            # who's calling
1452
1453     # If called by direct binding to an option, it will get the option
1454     # name and value as arguments. Remove these, if so.
1455     @_ = () if @_ == 2 && $_[0] eq $tag;
1456
1457     my $pa;
1458     if ( @_ > 1 ) {
1459         $pa = { @_ };
1460     }
1461     else {
1462         $pa = shift || {};
1463     }
1464
1465     # At this point, $pa can be a number (exit value), string
1466     # (message) or hash with options.
1467
1468     if ( UNIVERSAL::isa($pa, 'HASH') ) {
1469         # Get rid of -msg vs. -message ambiguity.
1470         $pa->{-message} = $pa->{-msg};
1471         delete($pa->{-msg});
1472     }
1473     elsif ( $pa =~ /^-?\d+$/ ) {
1474         $pa = { -exitval => $pa };
1475     }
1476     else {
1477         $pa = { -message => $pa };
1478     }
1479
1480     # These are _our_ defaults.
1481     $pa->{-verbose} = 0 unless exists($pa->{-verbose});
1482     $pa->{-exitval} = 0 unless exists($pa->{-exitval});
1483     $pa;
1484 }
1485
1486 # Sneak way to know what version the user requested.
1487 sub VERSION {
1488     $requested_version = $_[1];
1489     shift->SUPER::VERSION(@_);
1490 }
1491
1492 package Getopt::Long::CallBack;
1493
1494 sub new {
1495     my ($pkg, %atts) = @_;
1496     bless { %atts }, $pkg;
1497 }
1498
1499 sub name {
1500     my $self = shift;
1501     ''.$self->{name};
1502 }
1503
1504 use overload
1505   # Treat this object as an ordinary string for legacy API.
1506   '""'     => \&name,
1507   fallback => 1;
1508
1509 1;
1510
1511 ################ Documentation ################
1512
1513 =head1 NAME
1514
1515 Getopt::Long - Extended processing of command line options
1516
1517 =head1 SYNOPSIS
1518
1519   use Getopt::Long;
1520   my $data   = "file.dat";
1521   my $length = 24;
1522   my $verbose;
1523   GetOptions ("length=i" => \$length,    # numeric
1524               "file=s"   => \$data,      # string
1525               "verbose"  => \$verbose)   # flag
1526   or die("Error in command line arguments\n");
1527
1528 =head1 DESCRIPTION
1529
1530 The Getopt::Long module implements an extended getopt function called
1531 GetOptions(). It parses the command line from C<@ARGV>, recognizing
1532 and removing specified options and their possible values.
1533
1534 This function adheres to the POSIX syntax for command
1535 line options, with GNU extensions. In general, this means that options
1536 have long names instead of single letters, and are introduced with a
1537 double dash "--". Support for bundling of command line options, as was
1538 the case with the more traditional single-letter approach, is provided
1539 but not enabled by default.
1540
1541 =head1 Command Line Options, an Introduction
1542
1543 Command line operated programs traditionally take their arguments from
1544 the command line, for example filenames or other information that the
1545 program needs to know. Besides arguments, these programs often take
1546 command line I<options> as well. Options are not necessary for the
1547 program to work, hence the name 'option', but are used to modify its
1548 default behaviour. For example, a program could do its job quietly,
1549 but with a suitable option it could provide verbose information about
1550 what it did.
1551
1552 Command line options come in several flavours. Historically, they are
1553 preceded by a single dash C<->, and consist of a single letter.
1554
1555     -l -a -c
1556
1557 Usually, these single-character options can be bundled:
1558
1559     -lac
1560
1561 Options can have values, the value is placed after the option
1562 character. Sometimes with whitespace in between, sometimes not:
1563
1564     -s 24 -s24
1565
1566 Due to the very cryptic nature of these options, another style was
1567 developed that used long names. So instead of a cryptic C<-l> one
1568 could use the more descriptive C<--long>. To distinguish between a
1569 bundle of single-character options and a long one, two dashes are used
1570 to precede the option name. Early implementations of long options used
1571 a plus C<+> instead. Also, option values could be specified either
1572 like
1573
1574     --size=24
1575
1576 or
1577
1578     --size 24
1579
1580 The C<+> form is now obsolete and strongly deprecated.
1581
1582 =head1 Getting Started with Getopt::Long
1583
1584 Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was the
1585 first Perl module that provided support for handling the new style of
1586 command line options, in particular long option names, hence the Perl5
1587 name Getopt::Long. This module also supports single-character options
1588 and bundling.
1589
1590 To use Getopt::Long from a Perl program, you must include the
1591 following line in your Perl program:
1592
1593     use Getopt::Long;
1594
1595 This will load the core of the Getopt::Long module and prepare your
1596 program for using it. Most of the actual Getopt::Long code is not
1597 loaded until you really call one of its functions.
1598
1599 In the default configuration, options names may be abbreviated to
1600 uniqueness, case does not matter, and a single dash is sufficient,
1601 even for long option names. Also, options may be placed between
1602 non-option arguments. See L<Configuring Getopt::Long> for more
1603 details on how to configure Getopt::Long.
1604
1605 =head2 Simple options
1606
1607 The most simple options are the ones that take no values. Their mere
1608 presence on the command line enables the option. Popular examples are:
1609
1610     --all --verbose --quiet --debug
1611
1612 Handling simple options is straightforward:
1613
1614     my $verbose = '';   # option variable with default value (false)
1615     my $all = '';       # option variable with default value (false)
1616     GetOptions ('verbose' => \$verbose, 'all' => \$all);
1617
1618 The call to GetOptions() parses the command line arguments that are
1619 present in C<@ARGV> and sets the option variable to the value C<1> if
1620 the option did occur on the command line. Otherwise, the option
1621 variable is not touched. Setting the option value to true is often
1622 called I<enabling> the option.
1623
1624 The option name as specified to the GetOptions() function is called
1625 the option I<specification>. Later we'll see that this specification
1626 can contain more than just the option name. The reference to the
1627 variable is called the option I<destination>.
1628
1629 GetOptions() will return a true value if the command line could be
1630 processed successfully. Otherwise, it will write error messages using
1631 die() and warn(), and return a false result.
1632
1633 =head2 A little bit less simple options
1634
1635 Getopt::Long supports two useful variants of simple options:
1636 I<negatable> options and I<incremental> options.
1637
1638 A negatable option is specified with an exclamation mark C<!> after the
1639 option name:
1640
1641     my $verbose = '';   # option variable with default value (false)
1642     GetOptions ('verbose!' => \$verbose);
1643
1644 Now, using C<--verbose> on the command line will enable C<$verbose>,
1645 as expected. But it is also allowed to use C<--noverbose>, which will
1646 disable C<$verbose> by setting its value to C<0>. Using a suitable
1647 default value, the program can find out whether C<$verbose> is false
1648 by default, or disabled by using C<--noverbose>.
1649
1650 An incremental option is specified with a plus C<+> after the
1651 option name:
1652
1653     my $verbose = '';   # option variable with default value (false)
1654     GetOptions ('verbose+' => \$verbose);
1655
1656 Using C<--verbose> on the command line will increment the value of
1657 C<$verbose>. This way the program can keep track of how many times the
1658 option occurred on the command line. For example, each occurrence of
1659 C<--verbose> could increase the verbosity level of the program.
1660
1661 =head2 Mixing command line option with other arguments
1662
1663 Usually programs take command line options as well as other arguments,
1664 for example, file names. It is good practice to always specify the
1665 options first, and the other arguments last. Getopt::Long will,
1666 however, allow the options and arguments to be mixed and 'filter out'
1667 all the options before passing the rest of the arguments to the
1668 program. To stop Getopt::Long from processing further arguments,
1669 insert a double dash C<--> on the command line:
1670
1671     --size 24 -- --all
1672
1673 In this example, C<--all> will I<not> be treated as an option, but
1674 passed to the program unharmed, in C<@ARGV>.
1675
1676 =head2 Options with values
1677
1678 For options that take values it must be specified whether the option
1679 value is required or not, and what kind of value the option expects.
1680
1681 Three kinds of values are supported: integer numbers, floating point
1682 numbers, and strings.
1683
1684 If the option value is required, Getopt::Long will take the
1685 command line argument that follows the option and assign this to the
1686 option variable. If, however, the option value is specified as
1687 optional, this will only be done if that value does not look like a
1688 valid command line option itself.
1689
1690     my $tag = '';       # option variable with default value
1691     GetOptions ('tag=s' => \$tag);
1692
1693 In the option specification, the option name is followed by an equals
1694 sign C<=> and the letter C<s>. The equals sign indicates that this
1695 option requires a value. The letter C<s> indicates that this value is
1696 an arbitrary string. Other possible value types are C<i> for integer
1697 values, and C<f> for floating point values. Using a colon C<:> instead
1698 of the equals sign indicates that the option value is optional. In
1699 this case, if no suitable value is supplied, string valued options get
1700 an empty string C<''> assigned, while numeric options are set to C<0>.
1701
1702 =head2 Options with multiple values
1703
1704 Options sometimes take several values. For example, a program could
1705 use multiple directories to search for library files:
1706
1707     --library lib/stdlib --library lib/extlib
1708
1709 To accomplish this behaviour, simply specify an array reference as the
1710 destination for the option:
1711
1712     GetOptions ("library=s" => \@libfiles);
1713
1714 Alternatively, you can specify that the option can have multiple
1715 values by adding a "@", and pass a scalar reference as the
1716 destination:
1717
1718     GetOptions ("library=s@" => \$libfiles);
1719
1720 Used with the example above, C<@libfiles> (or C<@$libfiles>) would
1721 contain two strings upon completion: C<"lib/stdlib"> and
1722 C<"lib/extlib">, in that order. It is also possible to specify that
1723 only integer or floating point numbers are acceptable values.
1724
1725 Often it is useful to allow comma-separated lists of values as well as
1726 multiple occurrences of the options. This is easy using Perl's split()
1727 and join() operators:
1728
1729     GetOptions ("library=s" => \@libfiles);
1730     @libfiles = split(/,/,join(',',@libfiles));
1731
1732 Of course, it is important to choose the right separator string for
1733 each purpose.
1734
1735 Warning: What follows is an experimental feature.
1736
1737 Options can take multiple values at once, for example
1738
1739     --coordinates 52.2 16.4 --rgbcolor 255 255 149
1740
1741 This can be accomplished by adding a repeat specifier to the option
1742 specification. Repeat specifiers are very similar to the C<{...}>
1743 repeat specifiers that can be used with regular expression patterns.
1744 For example, the above command line would be handled as follows:
1745
1746     GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color);
1747
1748 The destination for the option must be an array or array reference.
1749
1750 It is also possible to specify the minimal and maximal number of
1751 arguments an option takes. C<foo=s{2,4}> indicates an option that
1752 takes at least two and at most 4 arguments. C<foo=s{1,}> indicates one
1753 or more values; C<foo:s{,}> indicates zero or more option values.
1754
1755 =head2 Options with hash values
1756
1757 If the option destination is a reference to a hash, the option will
1758 take, as value, strings of the form I<key>C<=>I<value>. The value will
1759 be stored with the specified key in the hash.
1760
1761     GetOptions ("define=s" => \%defines);
1762
1763 Alternatively you can use:
1764
1765     GetOptions ("define=s%" => \$defines);
1766
1767 When used with command line options:
1768
1769     --define os=linux --define vendor=redhat
1770
1771 the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os">
1772 with value C<"linux"> and C<"vendor"> with value C<"redhat">. It is
1773 also possible to specify that only integer or floating point numbers
1774 are acceptable values. The keys are always taken to be strings.
1775
1776 =head2 User-defined subroutines to handle options
1777
1778 Ultimate control over what should be done when (actually: each time)
1779 an option is encountered on the command line can be achieved by
1780 designating a reference to a subroutine (or an anonymous subroutine)
1781 as the option destination. When GetOptions() encounters the option, it
1782 will call the subroutine with two or three arguments. The first
1783 argument is the name of the option. (Actually, it is an object that
1784 stringifies to the name of the option.) For a scalar or array destination,
1785 the second argument is the value to be stored. For a hash destination,
1786 the second argument is the key to the hash, and the third argument
1787 the value to be stored. It is up to the subroutine to store the value,
1788 or do whatever it thinks is appropriate.
1789
1790 A trivial application of this mechanism is to implement options that
1791 are related to each other. For example:
1792
1793     my $verbose = '';   # option variable with default value (false)
1794     GetOptions ('verbose' => \$verbose,
1795                 'quiet'   => sub { $verbose = 0 });
1796
1797 Here C<--verbose> and C<--quiet> control the same variable
1798 C<$verbose>, but with opposite values.
1799
1800 If the subroutine needs to signal an error, it should call die() with
1801 the desired error message as its argument. GetOptions() will catch the
1802 die(), issue the error message, and record that an error result must
1803 be returned upon completion.
1804
1805 If the text of the error message starts with an exclamation mark C<!>
1806 it is interpreted specially by GetOptions(). There is currently one
1807 special command implemented: C<die("!FINISH")> will cause GetOptions()
1808 to stop processing options, as if it encountered a double dash C<-->.
1809
1810 In version 2.37 the first argument to the callback function was
1811 changed from string to object. This was done to make room for
1812 extensions and more detailed control. The object stringifies to the
1813 option name so this change should not introduce compatibility
1814 problems.
1815
1816 Here is an example of how to access the option name and value from within
1817 a subroutine:
1818
1819     GetOptions ('opt=i' => \&handler);
1820     sub handler {
1821         my ($opt_name, $opt_value) = @_;
1822         print("Option name is $opt_name and value is $opt_value\n");
1823     }
1824
1825 =head2 Options with multiple names
1826
1827 Often it is user friendly to supply alternate mnemonic names for
1828 options. For example C<--height> could be an alternate name for
1829 C<--length>. Alternate names can be included in the option
1830 specification, separated by vertical bar C<|> characters. To implement
1831 the above example:
1832
1833     GetOptions ('length|height=f' => \$length);
1834
1835 The first name is called the I<primary> name, the other names are
1836 called I<aliases>. When using a hash to store options, the key will
1837 always be the primary name.
1838
1839 Multiple alternate names are possible.
1840
1841 =head2 Case and abbreviations
1842
1843 Without additional configuration, GetOptions() will ignore the case of
1844 option names, and allow the options to be abbreviated to uniqueness.
1845
1846     GetOptions ('length|height=f' => \$length, "head" => \$head);
1847
1848 This call will allow C<--l> and C<--L> for the length option, but
1849 requires a least C<--hea> and C<--hei> for the head and height options.
1850
1851 =head2 Summary of Option Specifications
1852
1853 Each option specifier consists of two parts: the name specification
1854 and the argument specification.
1855
1856 The name specification contains the name of the option, optionally
1857 followed by a list of alternative names separated by vertical bar
1858 characters.
1859
1860     length            option name is "length"
1861     length|size|l     name is "length", aliases are "size" and "l"
1862
1863 The argument specification is optional. If omitted, the option is
1864 considered boolean, a value of 1 will be assigned when the option is
1865 used on the command line.
1866
1867 The argument specification can be
1868
1869 =over 4
1870
1871 =item !
1872
1873 The option does not take an argument and may be negated by prefixing
1874 it with "no" or "no-". E.g. C<"foo!"> will allow C<--foo> (a value of
1875 1 will be assigned) as well as C<--nofoo> and C<--no-foo> (a value of
1876 0 will be assigned). If the option has aliases, this applies to the
1877 aliases as well.
1878
1879 Using negation on a single letter option when bundling is in effect is
1880 pointless and will result in a warning.
1881
1882 =item +
1883
1884 The option does not take an argument and will be incremented by 1
1885 every time it appears on the command line. E.g. C<"more+">, when used
1886 with C<--more --more --more>, will increment the value three times,
1887 resulting in a value of 3 (provided it was 0 or undefined at first).
1888
1889 The C<+> specifier is ignored if the option destination is not a scalar.
1890
1891 =item = I<type> [ I<desttype> ] [ I<repeat> ]
1892
1893 The option requires an argument of the given type. Supported types
1894 are:
1895
1896 =over 4
1897
1898 =item s
1899
1900 String. An arbitrary sequence of characters. It is valid for the
1901 argument to start with C<-> or C<-->.
1902
1903 =item i
1904
1905 Integer. An optional leading plus or minus sign, followed by a
1906 sequence of digits.
1907
1908 =item o
1909
1910 Extended integer, Perl style. This can be either an optional leading
1911 plus or minus sign, followed by a sequence of digits, or an octal
1912 string (a zero, optionally followed by '0', '1', .. '7'), or a
1913 hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case
1914 insensitive), or a binary string (C<0b> followed by a series of '0'
1915 and '1').
1916
1917 =item f
1918
1919 Real number. For example C<3.14>, C<-6.23E24> and so on.
1920
1921 =back
1922
1923 The I<desttype> can be C<@> or C<%> to specify that the option is
1924 list or a hash valued. This is only needed when the destination for
1925 the option value is not otherwise specified. It should be omitted when
1926 not needed.
1927
1928 The I<repeat> specifies the number of values this option takes per
1929 occurrence on the command line. It has the format C<{> [ I<min> ] [ C<,> [ I<max> ] ] C<}>.
1930
1931 I<min> denotes the minimal number of arguments. It defaults to 1 for
1932 options with C<=> and to 0 for options with C<:>, see below. Note that
1933 I<min> overrules the C<=> / C<:> semantics.
1934
1935 I<max> denotes the maximum number of arguments. It must be at least
1936 I<min>. If I<max> is omitted, I<but the comma is not>, there is no
1937 upper bound to the number of argument values taken.
1938
1939 =item : I<type> [ I<desttype> ]
1940
1941 Like C<=>, but designates the argument as optional.
1942 If omitted, an empty string will be assigned to string values options,
1943 and the value zero to numeric options.
1944
1945 Note that if a string argument starts with C<-> or C<-->, it will be
1946 considered an option on itself.
1947
1948 =item : I<number> [ I<desttype> ]
1949
1950 Like C<:i>, but if the value is omitted, the I<number> will be assigned.
1951
1952 =item : + [ I<desttype> ]
1953
1954 Like C<:i>, but if the value is omitted, the current value for the
1955 option will be incremented.
1956
1957 =back
1958
1959 =head1 Advanced Possibilities
1960
1961 =head2 Object oriented interface
1962
1963 Getopt::Long can be used in an object oriented way as well:
1964
1965     use Getopt::Long;
1966     $p = Getopt::Long::Parser->new;
1967     $p->configure(...configuration options...);
1968     if ($p->getoptions(...options descriptions...)) ...
1969     if ($p->getoptionsfromarray( \@array, ...options descriptions...)) ...
1970
1971 Configuration options can be passed to the constructor:
1972
1973     $p = new Getopt::Long::Parser
1974              config => [...configuration options...];
1975
1976 =head2 Thread Safety
1977
1978 Getopt::Long is thread safe when using ithreads as of Perl 5.8.  It is
1979 I<not> thread safe when using the older (experimental and now
1980 obsolete) threads implementation that was added to Perl 5.005.
1981
1982 =head2 Documentation and help texts
1983
1984 Getopt::Long encourages the use of Pod::Usage to produce help
1985 messages. For example:
1986
1987     use Getopt::Long;
1988     use Pod::Usage;
1989
1990     my $man = 0;
1991     my $help = 0;
1992
1993     GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
1994     pod2usage(1) if $help;
1995     pod2usage(-exitval => 0, -verbose => 2) if $man;
1996
1997     __END__
1998
1999     =head1 NAME
2000
2001     sample - Using Getopt::Long and Pod::Usage
2002
2003     =head1 SYNOPSIS
2004
2005     sample [options] [file ...]
2006
2007      Options:
2008        -help            brief help message
2009        -man             full documentation
2010
2011     =head1 OPTIONS
2012
2013     =over 8
2014
2015     =item B<-help>
2016
2017     Print a brief help message and exits.
2018
2019     =item B<-man>
2020
2021     Prints the manual page and exits.
2022
2023     =back
2024
2025     =head1 DESCRIPTION
2026
2027     B<This program> will read the given input file(s) and do something
2028     useful with the contents thereof.
2029
2030     =cut
2031
2032 See L<Pod::Usage> for details.
2033
2034 =head2 Parsing options from an arbitrary array
2035
2036 By default, GetOptions parses the options that are present in the
2037 global array C<@ARGV>. A special entry C<GetOptionsFromArray> can be
2038 used to parse options from an arbitrary array.
2039
2040     use Getopt::Long qw(GetOptionsFromArray);
2041     $ret = GetOptionsFromArray(\@myopts, ...);
2042
2043 When used like this, options and their possible values are removed
2044 from C<@myopts>, the global C<@ARGV> is not touched at all.
2045
2046 The following two calls behave identically:
2047
2048     $ret = GetOptions( ... );
2049     $ret = GetOptionsFromArray(\@ARGV, ... );
2050
2051 This also means that a first argument hash reference now becomes the
2052 second argument:
2053
2054     $ret = GetOptions(\%opts, ... );
2055     $ret = GetOptionsFromArray(\@ARGV, \%opts, ... );
2056
2057 =head2 Parsing options from an arbitrary string
2058
2059 A special entry C<GetOptionsFromString> can be used to parse options
2060 from an arbitrary string.
2061
2062     use Getopt::Long qw(GetOptionsFromString);
2063     $ret = GetOptionsFromString($string, ...);
2064
2065 The contents of the string are split into arguments using a call to
2066 C<Text::ParseWords::shellwords>. As with C<GetOptionsFromArray>, the
2067 global C<@ARGV> is not touched.
2068
2069 It is possible that, upon completion, not all arguments in the string
2070 have been processed. C<GetOptionsFromString> will, when called in list
2071 context, return both the return status and an array reference to any
2072 remaining arguments:
2073
2074     ($ret, $args) = GetOptionsFromString($string, ... );
2075
2076 If any arguments remain, and C<GetOptionsFromString> was not called in
2077 list context, a message will be given and C<GetOptionsFromString> will
2078 return failure.
2079
2080 As with GetOptionsFromArray, a first argument hash reference now
2081 becomes the second argument.
2082
2083 =head2 Storing options values in a hash
2084
2085 Sometimes, for example when there are a lot of options, having a
2086 separate variable for each of them can be cumbersome. GetOptions()
2087 supports, as an alternative mechanism, storing options values in a
2088 hash.
2089
2090 To obtain this, a reference to a hash must be passed I<as the first
2091 argument> to GetOptions(). For each option that is specified on the
2092 command line, the option value will be stored in the hash with the
2093 option name as key. Options that are not actually used on the command
2094 line will not be put in the hash, on other words,
2095 C<exists($h{option})> (or defined()) can be used to test if an option
2096 was used. The drawback is that warnings will be issued if the program
2097 runs under C<use strict> and uses C<$h{option}> without testing with
2098 exists() or defined() first.
2099
2100     my %h = ();
2101     GetOptions (\%h, 'length=i');       # will store in $h{length}
2102
2103 For options that take list or hash values, it is necessary to indicate
2104 this by appending an C<@> or C<%> sign after the type:
2105
2106     GetOptions (\%h, 'colours=s@');     # will push to @{$h{colours}}
2107
2108 To make things more complicated, the hash may contain references to
2109 the actual destinations, for example:
2110
2111     my $len = 0;
2112     my %h = ('length' => \$len);
2113     GetOptions (\%h, 'length=i');       # will store in $len
2114
2115 This example is fully equivalent with:
2116
2117     my $len = 0;
2118     GetOptions ('length=i' => \$len);   # will store in $len
2119
2120 Any mixture is possible. For example, the most frequently used options
2121 could be stored in variables while all other options get stored in the
2122 hash:
2123
2124     my $verbose = 0;                    # frequently referred
2125     my $debug = 0;                      # frequently referred
2126     my %h = ('verbose' => \$verbose, 'debug' => \$debug);
2127     GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i');
2128     if ( $verbose ) { ... }
2129     if ( exists $h{filter} ) { ... option 'filter' was specified ... }
2130
2131 =head2 Bundling
2132
2133 With bundling it is possible to set several single-character options
2134 at once. For example if C<a>, C<v> and C<x> are all valid options,
2135
2136     -vax
2137
2138 would set all three.
2139
2140 Getopt::Long supports two levels of bundling. To enable bundling, a
2141 call to Getopt::Long::Configure is required.
2142
2143 The first level of bundling can be enabled with:
2144
2145     Getopt::Long::Configure ("bundling");
2146
2147 Configured this way, single-character options can be bundled but long
2148 options B<must> always start with a double dash C<--> to avoid
2149 ambiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid
2150 options,
2151
2152     -vax
2153
2154 would set C<a>, C<v> and C<x>, but
2155
2156     --vax
2157
2158 would set C<vax>.
2159
2160 The second level of bundling lifts this restriction. It can be enabled
2161 with:
2162
2163     Getopt::Long::Configure ("bundling_override");
2164
2165 Now, C<-vax> would set the option C<vax>.
2166
2167 When any level of bundling is enabled, option values may be inserted
2168 in the bundle. For example:
2169
2170     -h24w80
2171
2172 is equivalent to
2173
2174     -h 24 -w 80
2175
2176 When configured for bundling, single-character options are matched
2177 case sensitive while long options are matched case insensitive. To
2178 have the single-character options matched case insensitive as well,
2179 use:
2180
2181     Getopt::Long::Configure ("bundling", "ignorecase_always");
2182
2183 It goes without saying that bundling can be quite confusing.
2184
2185 =head2 The lonesome dash
2186
2187 Normally, a lone dash C<-> on the command line will not be considered
2188 an option. Option processing will terminate (unless "permute" is
2189 configured) and the dash will be left in C<@ARGV>.
2190
2191 It is possible to get special treatment for a lone dash. This can be
2192 achieved by adding an option specification with an empty name, for
2193 example:
2194
2195     GetOptions ('' => \$stdio);
2196
2197 A lone dash on the command line will now be a legal option, and using
2198 it will set variable C<$stdio>.
2199
2200 =head2 Argument callback
2201
2202 A special option 'name' C<< <> >> can be used to designate a subroutine
2203 to handle non-option arguments. When GetOptions() encounters an
2204 argument that does not look like an option, it will immediately call this
2205 subroutine and passes it one parameter: the argument name. Well, actually
2206 it is an object that stringifies to the argument name.
2207
2208 For example:
2209
2210     my $width = 80;
2211     sub process { ... }
2212     GetOptions ('width=i' => \$width, '<>' => \&process);
2213
2214 When applied to the following command line:
2215
2216     arg1 --width=72 arg2 --width=60 arg3
2217
2218 This will call
2219 C<process("arg1")> while C<$width> is C<80>,
2220 C<process("arg2")> while C<$width> is C<72>, and
2221 C<process("arg3")> while C<$width> is C<60>.
2222
2223 This feature requires configuration option B<permute>, see section
2224 L<Configuring Getopt::Long>.
2225
2226 =head1 Configuring Getopt::Long
2227
2228 Getopt::Long can be configured by calling subroutine
2229 Getopt::Long::Configure(). This subroutine takes a list of quoted
2230 strings, each specifying a configuration option to be enabled, e.g.
2231 C<ignore_case>, or disabled, e.g. C<no_ignore_case>. Case does not
2232 matter. Multiple calls to Configure() are possible.
2233
2234 Alternatively, as of version 2.24, the configuration options may be
2235 passed together with the C<use> statement:
2236
2237     use Getopt::Long qw(:config no_ignore_case bundling);
2238
2239 The following options are available:
2240
2241 =over 12
2242
2243 =item default
2244
2245 This option causes all configuration options to be reset to their
2246 default values.
2247
2248 =item posix_default
2249
2250 This option causes all configuration options to be reset to their
2251 default values as if the environment variable POSIXLY_CORRECT had
2252 been set.
2253
2254 =item auto_abbrev
2255
2256 Allow option names to be abbreviated to uniqueness.
2257 Default is enabled unless environment variable
2258 POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled.
2259
2260 =item getopt_compat
2261
2262 Allow C<+> to start options.
2263 Default is enabled unless environment variable
2264 POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled.
2265
2266 =item gnu_compat
2267
2268 C<gnu_compat> controls whether C<--opt=> is allowed, and what it should
2269 do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>,
2270 C<--opt=> will give option C<opt> and empty value.
2271 This is the way GNU getopt_long() does it.
2272
2273 =item gnu_getopt
2274
2275 This is a short way of setting C<gnu_compat> C<bundling> C<permute>
2276 C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be
2277 fully compatible with GNU getopt_long().
2278
2279 =item require_order
2280
2281 Whether command line arguments are allowed to be mixed with options.
2282 Default is disabled unless environment variable
2283 POSIXLY_CORRECT has been set, in which case C<require_order> is enabled.
2284
2285 See also C<permute>, which is the opposite of C<require_order>.
2286
2287 =item permute
2288
2289 Whether command line arguments are allowed to be mixed with options.
2290 Default is enabled unless environment variable
2291 POSIXLY_CORRECT has been set, in which case C<permute> is disabled.
2292 Note that C<permute> is the opposite of C<require_order>.
2293
2294 If C<permute> is enabled, this means that
2295
2296     --foo arg1 --bar arg2 arg3
2297
2298 is equivalent to
2299
2300     --foo --bar arg1 arg2 arg3
2301
2302 If an argument callback routine is specified, C<@ARGV> will always be
2303 empty upon successful return of GetOptions() since all options have been
2304 processed. The only exception is when C<--> is used:
2305
2306     --foo arg1 --bar arg2 -- arg3
2307
2308 This will call the callback routine for arg1 and arg2, and then
2309 terminate GetOptions() leaving C<"arg3"> in C<@ARGV>.
2310
2311 If C<require_order> is enabled, options processing
2312 terminates when the first non-option is encountered.
2313
2314     --foo arg1 --bar arg2 arg3
2315
2316 is equivalent to
2317
2318     --foo -- arg1 --bar arg2 arg3
2319
2320 If C<pass_through> is also enabled, options processing will terminate
2321 at the first unrecognized option, or non-option, whichever comes
2322 first.
2323
2324 =item bundling (default: disabled)
2325
2326 Enabling this option will allow single-character options to be
2327 bundled. To distinguish bundles from long option names, long options
2328 I<must> be introduced with C<--> and bundles with C<->.
2329
2330 Note that, if you have options C<a>, C<l> and C<all>, and
2331 auto_abbrev enabled, possible arguments and option settings are:
2332
2333     using argument               sets option(s)
2334     ------------------------------------------
2335     -a, --a                      a
2336     -l, --l                      l
2337     -al, -la, -ala, -all,...     a, l
2338     --al, --all                  all
2339
2340 The surprising part is that C<--a> sets option C<a> (due to auto
2341 completion), not C<all>.
2342
2343 Note: disabling C<bundling> also disables C<bundling_override>.
2344
2345 =item bundling_override (default: disabled)
2346
2347 If C<bundling_override> is enabled, bundling is enabled as with
2348 C<bundling> but now long option names override option bundles.
2349
2350 Note: disabling C<bundling_override> also disables C<bundling>.
2351
2352 B<Note:> Using option bundling can easily lead to unexpected results,
2353 especially when mixing long options and bundles. Caveat emptor.
2354
2355 =item ignore_case  (default: enabled)
2356
2357 If enabled, case is ignored when matching option names. If, however,
2358 bundling is enabled as well, single character options will be treated
2359 case-sensitive.
2360
2361 With C<ignore_case>, option specifications for options that only
2362 differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as
2363 duplicates.
2364
2365 Note: disabling C<ignore_case> also disables C<ignore_case_always>.
2366
2367 =item ignore_case_always (default: disabled)
2368
2369 When bundling is in effect, case is ignored on single-character
2370 options also.
2371
2372 Note: disabling C<ignore_case_always> also disables C<ignore_case>.
2373
2374 =item auto_version (default:disabled)
2375
2376 Automatically provide support for the B<--version> option if
2377 the application did not specify a handler for this option itself.
2378
2379 Getopt::Long will provide a standard version message that includes the
2380 program name, its version (if $main::VERSION is defined), and the
2381 versions of Getopt::Long and Perl. The message will be written to
2382 standard output and processing will terminate.
2383
2384 C<auto_version> will be enabled if the calling program explicitly
2385 specified a version number higher than 2.32 in the C<use> or
2386 C<require> statement.
2387
2388 =item auto_help (default:disabled)
2389
2390 Automatically provide support for the B<--help> and B<-?> options if
2391 the application did not specify a handler for this option itself.
2392
2393 Getopt::Long will provide a help message using module L<Pod::Usage>. The
2394 message, derived from the SYNOPSIS POD section, will be written to
2395 standard output and processing will terminate.
2396
2397 C<auto_help> will be enabled if the calling program explicitly
2398 specified a version number higher than 2.32 in the C<use> or
2399 C<require> statement.
2400
2401 =item pass_through (default: disabled)
2402
2403 Options that are unknown, ambiguous or supplied with an invalid option
2404 value are passed through in C<@ARGV> instead of being flagged as
2405 errors. This makes it possible to write wrapper scripts that process
2406 only part of the user supplied command line arguments, and pass the
2407 remaining options to some other program.
2408
2409 If C<require_order> is enabled, options processing will terminate at
2410 the first unrecognized option, or non-option, whichever comes first.
2411 However, if C<permute> is enabled instead, results can become confusing.
2412
2413 Note that the options terminator (default C<-->), if present, will
2414 also be passed through in C<@ARGV>.
2415
2416 =item prefix
2417
2418 The string that starts options. If a constant string is not
2419 sufficient, see C<prefix_pattern>.
2420
2421 =item prefix_pattern
2422
2423 A Perl pattern that identifies the strings that introduce options.
2424 Default is C<--|-|\+> unless environment variable
2425 POSIXLY_CORRECT has been set, in which case it is C<--|->.
2426
2427 =item long_prefix_pattern
2428
2429 A Perl pattern that allows the disambiguation of long and short
2430 prefixes. Default is C<-->.
2431
2432 Typically you only need to set this if you are using nonstandard
2433 prefixes and want some or all of them to have the same semantics as
2434 '--' does under normal circumstances.
2435
2436 For example, setting prefix_pattern to C<--|-|\+|\/> and
2437 long_prefix_pattern to C<--|\/> would add Win32 style argument
2438 handling.
2439
2440 =item debug (default: disabled)
2441
2442 Enable debugging output.
2443
2444 =back
2445
2446 =head1 Exportable Methods
2447
2448 =over
2449
2450 =item VersionMessage
2451
2452 This subroutine provides a standard version message. Its argument can be:
2453
2454 =over 4
2455
2456 =item *
2457
2458 A string containing the text of a message to print I<before> printing
2459 the standard message.
2460
2461 =item *
2462
2463 A numeric value corresponding to the desired exit status.
2464
2465 =item *
2466
2467 A reference to a hash.
2468
2469 =back
2470
2471 If more than one argument is given then the entire argument list is
2472 assumed to be a hash.  If a hash is supplied (either as a reference or
2473 as a list) it should contain one or more elements with the following
2474 keys:
2475
2476 =over 4
2477
2478 =item C<-message>
2479
2480 =item C<-msg>
2481
2482 The text of a message to print immediately prior to printing the
2483 program's usage message.
2484
2485 =item C<-exitval>
2486
2487 The desired exit status to pass to the B<exit()> function.
2488 This should be an integer, or else the string "NOEXIT" to
2489 indicate that control should simply be returned without
2490 terminating the invoking process.
2491
2492 =item C<-output>
2493
2494 A reference to a filehandle, or the pathname of a file to which the
2495 usage message should be written. The default is C<\*STDERR> unless the
2496 exit value is less than 2 (in which case the default is C<\*STDOUT>).
2497
2498 =back
2499
2500 You cannot tie this routine directly to an option, e.g.:
2501
2502     GetOptions("version" => \&VersionMessage);
2503
2504 Use this instead:
2505
2506     GetOptions("version" => sub { VersionMessage() });
2507
2508 =item HelpMessage
2509
2510 This subroutine produces a standard help message, derived from the
2511 program's POD section SYNOPSIS using L<Pod::Usage>. It takes the same
2512 arguments as VersionMessage(). In particular, you cannot tie it
2513 directly to an option, e.g.:
2514
2515     GetOptions("help" => \&HelpMessage);
2516
2517 Use this instead:
2518
2519     GetOptions("help" => sub { HelpMessage() });
2520
2521 =back
2522
2523 =head1 Return values and Errors
2524
2525 Configuration errors and errors in the option definitions are
2526 signalled using die() and will terminate the calling program unless
2527 the call to Getopt::Long::GetOptions() was embedded in C<eval { ...
2528 }>, or die() was trapped using C<$SIG{__DIE__}>.
2529
2530 GetOptions returns true to indicate success.
2531 It returns false when the function detected one or more errors during
2532 option parsing. These errors are signalled using warn() and can be
2533 trapped with C<$SIG{__WARN__}>.
2534
2535 =head1 Legacy
2536
2537 The earliest development of C<newgetopt.pl> started in 1990, with Perl
2538 version 4. As a result, its development, and the development of
2539 Getopt::Long, has gone through several stages. Since backward
2540 compatibility has always been extremely important, the current version
2541 of Getopt::Long still supports a lot of constructs that nowadays are
2542 no longer necessary or otherwise unwanted. This section describes
2543 briefly some of these 'features'.
2544
2545 =head2 Default destinations
2546
2547 When no destination is specified for an option, GetOptions will store
2548 the resultant value in a global variable named C<opt_>I<XXX>, where
2549 I<XXX> is the primary name of this option. When a program executes
2550 under C<use strict> (recommended), these variables must be
2551 pre-declared with our() or C<use vars>.
2552
2553     our $opt_length = 0;
2554     GetOptions ('length=i');    # will store in $opt_length
2555
2556 To yield a usable Perl variable, characters that are not part of the
2557 syntax for variables are translated to underscores. For example,
2558 C<--fpp-struct-return> will set the variable
2559 C<$opt_fpp_struct_return>. Note that this variable resides in the
2560 namespace of the calling program, not necessarily C<main>. For
2561 example:
2562
2563     GetOptions ("size=i", "sizes=i@");
2564
2565 with command line "-size 10 -sizes 24 -sizes 48" will perform the
2566 equivalent of the assignments
2567
2568     $opt_size = 10;
2569     @opt_sizes = (24, 48);
2570
2571 =head2 Alternative option starters
2572
2573 A string of alternative option starter characters may be passed as the
2574 first argument (or the first argument after a leading hash reference
2575 argument).
2576
2577     my $len = 0;
2578     GetOptions ('/', 'length=i' => $len);
2579
2580 Now the command line may look like:
2581
2582     /length 24 -- arg
2583
2584 Note that to terminate options processing still requires a double dash
2585 C<-->.
2586
2587 GetOptions() will not interpret a leading C<< "<>" >> as option starters
2588 if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as
2589 option starters, use C<< "><" >>. Confusing? Well, B<using a starter
2590 argument is strongly deprecated> anyway.
2591
2592 =head2 Configuration variables
2593
2594 Previous versions of Getopt::Long used variables for the purpose of
2595 configuring. Although manipulating these variables still work, it is
2596 strongly encouraged to use the C<Configure> routine that was introduced
2597 in version 2.17. Besides, it is much easier.
2598
2599 =head1 Tips and Techniques
2600
2601 =head2 Pushing multiple values in a hash option
2602
2603 Sometimes you want to combine the best of hashes and arrays. For
2604 example, the command line:
2605
2606   --list add=first --list add=second --list add=third
2607
2608 where each successive 'list add' option will push the value of add
2609 into array ref $list->{'add'}. The result would be like
2610
2611   $list->{add} = [qw(first second third)];
2612
2613 This can be accomplished with a destination routine:
2614
2615   GetOptions('list=s%' =>
2616                sub { push(@{$list{$_[1]}}, $_[2]) });
2617
2618 =head1 Troubleshooting
2619
2620 =head2 GetOptions does not return a false result when an option is not supplied
2621
2622 That's why they're called 'options'.
2623
2624 =head2 GetOptions does not split the command line correctly
2625
2626 The command line is not split by GetOptions, but by the command line
2627 interpreter (CLI). On Unix, this is the shell. On Windows, it is
2628 COMMAND.COM or CMD.EXE. Other operating systems have other CLIs.
2629
2630 It is important to know that these CLIs may behave different when the
2631 command line contains special characters, in particular quotes or
2632 backslashes. For example, with Unix shells you can use single quotes
2633 (C<'>) and double quotes (C<">) to group words together. The following
2634 alternatives are equivalent on Unix:
2635
2636     "two words"
2637     'two words'
2638     two\ words
2639
2640 In case of doubt, insert the following statement in front of your Perl
2641 program:
2642
2643     print STDERR (join("|",@ARGV),"\n");
2644
2645 to verify how your CLI passes the arguments to the program.
2646
2647 =head2 Undefined subroutine &main::GetOptions called
2648
2649 Are you running Windows, and did you write
2650
2651     use GetOpt::Long;
2652
2653 (note the capital 'O')?
2654
2655 =head2 How do I put a "-?" option into a Getopt::Long?
2656
2657 You can only obtain this using an alias, and Getopt::Long of at least
2658 version 2.13.
2659
2660     use Getopt::Long;
2661     GetOptions ("help|?");    # -help and -? will both set $opt_help
2662
2663 Other characters that can't appear in Perl identifiers are also supported
2664 as aliases with Getopt::Long of at least version 2.39.
2665
2666 As of version 2.32 Getopt::Long provides auto-help, a quick and easy way
2667 to add the options --help and -? to your program, and handle them.
2668
2669 See C<auto_help> in section L<Configuring Getopt::Long>.
2670
2671 =head1 AUTHOR
2672
2673 Johan Vromans <jvromans@squirrel.nl>
2674
2675 =head1 COPYRIGHT AND DISCLAIMER
2676
2677 This program is Copyright 1990,2013 by Johan Vromans.
2678 This program is free software; you can redistribute it and/or
2679 modify it under the terms of the Perl Artistic License or the
2680 GNU General Public License as published by the Free Software
2681 Foundation; either version 2 of the License, or (at your option) any
2682 later version.
2683
2684 This program is distributed in the hope that it will be useful,
2685 but WITHOUT ANY WARRANTY; without even the implied warranty of
2686 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
2687 GNU General Public License for more details.
2688
2689 If you do not have a copy of the GNU General Public License write to
2690 the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
2691 MA 02139, USA.
2692
2693 =cut
2694