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