This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
664c8b63c9170bd9fd884394f453fd4171b1f807
[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: Sat May 27 12:11:39 2017
8 # Update Count    : 1715
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.50;
22 # For testing versions only.
23 use vars qw($VERSION_STRING);
24 $VERSION_STRING = "2.50";
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 ",
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 ) {
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                      # Alias names, or "?"
809                      (?: \| (?: \? | \w[-\w]* ) )*
810                      # Aliases
811                      (?: \| (?: [^-|!+=:][^|!+=:]* )? )*
812                    )?
813                    (
814                      # Either modifiers ...
815                      [!+]
816                      |
817                      # ... or a value/dest/repeat specification
818                      [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
819                      |
820                      # ... or an optional-with-default spec
821                      : (?: -?\d+ | \+ ) [@%]?
822                    )?
823                    $;x ) {
824         return (undef, "Error in option spec: \"$opt\"\n");
825     }
826
827     my ($names, $spec) = ($1, $2);
828     $spec = '' unless defined $spec;
829
830     # $orig keeps track of the primary name the user specified.
831     # This name will be used for the internal or external linkage.
832     # In other words, if the user specifies "FoO|BaR", it will
833     # match any case combinations of 'foo' and 'bar', but if a global
834     # variable needs to be set, it will be $opt_FoO in the exact case
835     # as specified.
836     my $orig;
837
838     my @names;
839     if ( defined $names ) {
840         @names =  split (/\|/, $names);
841         $orig = $names[0];
842     }
843     else {
844         @names = ('');
845         $orig = '';
846     }
847
848     # Construct the opctl entries.
849     my $entry;
850     if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
851         # Fields are hard-wired here.
852         $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0];
853     }
854     elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) {
855         my $def = $1;
856         my $dest = $2;
857         my $type = $def eq '+' ? 'I' : 'i';
858         $dest ||= '$';
859         $dest = $dest eq '@' ? CTL_DEST_ARRAY
860           : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
861         # Fields are hard-wired here.
862         $entry = [$type,$orig,$def eq '+' ? undef : $def,
863                   $dest,0,1];
864     }
865     else {
866         my ($mand, $type, $dest) =
867           $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
868         return (undef, "Cannot repeat while bundling: \"$opt\"\n")
869           if $bundling && defined($4);
870         my ($mi, $cm, $ma) = ($5, $6, $7);
871         return (undef, "{0} is useless in option spec: \"$opt\"\n")
872           if defined($mi) && !$mi && !defined($ma) && !defined($cm);
873
874         $type = 'i' if $type eq 'n';
875         $dest ||= '$';
876         $dest = $dest eq '@' ? CTL_DEST_ARRAY
877           : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
878         # Default minargs to 1/0 depending on mand status.
879         $mi = $mand eq '=' ? 1 : 0 unless defined $mi;
880         # Adjust mand status according to minargs.
881         $mand = $mi ? '=' : ':';
882         # Adjust maxargs.
883         $ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
884         return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
885           if defined($ma) && !$ma;
886         return (undef, "Max less than min in option spec: \"$opt\"\n")
887           if defined($ma) && $ma < $mi;
888
889         # Fields are hard-wired here.
890         $entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
891     }
892
893     # Process all names. First is canonical, the rest are aliases.
894     my $dups = '';
895     foreach ( @names ) {
896
897         $_ = lc ($_)
898           if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
899
900         if ( exists $opctl->{$_} ) {
901             $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
902         }
903
904         if ( $spec eq '!' ) {
905             $opctl->{"no$_"} = $entry;
906             $opctl->{"no-$_"} = $entry;
907             $opctl->{$_} = [@$entry];
908             $opctl->{$_}->[CTL_TYPE] = '';
909         }
910         else {
911             $opctl->{$_} = $entry;
912         }
913     }
914
915     if ( $dups && $^W ) {
916         foreach ( split(/\n+/, $dups) ) {
917             warn($_."\n");
918         }
919     }
920     ($names[0], $orig);
921 }
922
923 # Option lookup.
924 sub FindOption ($$$$$) {
925
926     # returns (1, $opt, $ctl, $arg, $key) if okay,
927     # returns (1, undef) if option in error,
928     # returns (0) otherwise.
929
930     my ($argv, $prefix, $argend, $opt, $opctl) = @_;
931
932     print STDERR ("=> find \"$opt\"\n") if $debug;
933
934     return (0) unless defined($opt);
935     return (0) unless $opt =~ /^($prefix)(.*)$/s;
936     return (0) if $opt eq "-" && !defined $opctl->{''};
937
938     $opt = substr( $opt, length($1) ); # retain taintedness
939     my $starter = $1;
940
941     print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
942
943     my $optarg;                 # value supplied with --opt=value
944     my $rest;                   # remainder from unbundling
945
946     # If it is a long option, it may include the value.
947     # With getopt_compat, only if not bundling.
948     if ( ($starter=~/^$longprefix$/
949           || ($getopt_compat && ($bundling == 0 || $bundling == 2)))
950          && (my $oppos = index($opt, '=', 1)) > 0) {
951         my $optorg = $opt;
952         $opt = substr($optorg, 0, $oppos);
953         $optarg = substr($optorg, $oppos + 1); # retain tainedness
954         print STDERR ("=> option \"", $opt,
955                       "\", optarg = \"$optarg\"\n") if $debug;
956     }
957
958     #### Look it up ###
959
960     my $tryopt = $opt;          # option to try
961
962     if ( ( $bundling || $bundling_values ) && $starter eq '-' ) {
963
964         # To try overrides, obey case ignore.
965         $tryopt = $ignorecase ? lc($opt) : $opt;
966
967         # If bundling == 2, long options can override bundles.
968         if ( $bundling == 2 && length($tryopt) > 1
969              && defined ($opctl->{$tryopt}) ) {
970             print STDERR ("=> $starter$tryopt overrides unbundling\n")
971               if $debug;
972         }
973
974         # If bundling_values, option may be followed by the value.
975         elsif ( $bundling_values ) {
976             $tryopt = $opt;
977             # Unbundle single letter option.
978             $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
979             $tryopt = substr ($tryopt, 0, 1);
980             $tryopt = lc ($tryopt) if $ignorecase > 1;
981             print STDERR ("=> $starter$tryopt unbundled from ",
982                           "$starter$tryopt$rest\n") if $debug;
983             # Whatever remains may not be considered an option.
984             $optarg = $rest eq '' ? undef : $rest;
985             $rest = undef;
986         }
987
988         # Split off a single letter and leave the rest for
989         # further processing.
990         else {
991             $tryopt = $opt;
992             # Unbundle single letter option.
993             $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
994             $tryopt = substr ($tryopt, 0, 1);
995             $tryopt = lc ($tryopt) if $ignorecase > 1;
996             print STDERR ("=> $starter$tryopt unbundled from ",
997                           "$starter$tryopt$rest\n") if $debug;
998             $rest = undef unless $rest ne '';
999         }
1000     }
1001
1002     # Try auto-abbreviation.
1003     elsif ( $autoabbrev && $opt ne "" ) {
1004         # Sort the possible long option names.
1005         my @names = sort(keys (%$opctl));
1006         # Downcase if allowed.
1007         $opt = lc ($opt) if $ignorecase;
1008         $tryopt = $opt;
1009         # Turn option name into pattern.
1010         my $pat = quotemeta ($opt);
1011         # Look up in option names.
1012         my @hits = grep (/^$pat/, @names);
1013         print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
1014                       "out of ", scalar(@names), "\n") if $debug;
1015
1016         # Check for ambiguous results.
1017         unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
1018             # See if all matches are for the same option.
1019             my %hit;
1020             foreach ( @hits ) {
1021                 my $hit = $opctl->{$_}->[CTL_CNAME]
1022                   if defined $opctl->{$_}->[CTL_CNAME];
1023                 $hit = "no" . $hit if $opctl->{$_}->[CTL_TYPE] eq '!';
1024                 $hit{$hit} = 1;
1025             }
1026             # Remove auto-supplied options (version, help).
1027             if ( keys(%hit) == 2 ) {
1028                 if ( $auto_version && exists($hit{version}) ) {
1029                     delete $hit{version};
1030                 }
1031                 elsif ( $auto_help && exists($hit{help}) ) {
1032                     delete $hit{help};
1033                 }
1034             }
1035             # Now see if it really is ambiguous.
1036             unless ( keys(%hit) == 1 ) {
1037                 return (0) if $passthrough;
1038                 warn ("Option ", $opt, " is ambiguous (",
1039                       join(", ", @hits), ")\n");
1040                 $error++;
1041                 return (1, undef);
1042             }
1043             @hits = keys(%hit);
1044         }
1045
1046         # Complete the option name, if appropriate.
1047         if ( @hits == 1 && $hits[0] ne $opt ) {
1048             $tryopt = $hits[0];
1049             $tryopt = lc ($tryopt)
1050               if $ignorecase > (($bundling && length($tryopt) == 1) ? 1 : 0);
1051             print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
1052                 if $debug;
1053         }
1054     }
1055
1056     # Map to all lowercase if ignoring case.
1057     elsif ( $ignorecase ) {
1058         $tryopt = lc ($opt);
1059     }
1060
1061     # Check validity by fetching the info.
1062     my $ctl = $opctl->{$tryopt};
1063     unless  ( defined $ctl ) {
1064         return (0) if $passthrough;
1065         # Pretend one char when bundling.
1066         if ( $bundling == 1 && length($starter) == 1 ) {
1067             $opt = substr($opt,0,1);
1068             unshift (@$argv, $starter.$rest) if defined $rest;
1069         }
1070         if ( $opt eq "" ) {
1071             warn ("Missing option after ", $starter, "\n");
1072         }
1073         else {
1074             warn ("Unknown option: ", $opt, "\n");
1075         }
1076         $error++;
1077         return (1, undef);
1078     }
1079     # Apparently valid.
1080     $opt = $tryopt;
1081     print STDERR ("=> found ", OptCtl($ctl),
1082                   " for \"", $opt, "\"\n") if $debug;
1083
1084     #### Determine argument status ####
1085
1086     # If it is an option w/o argument, we're almost finished with it.
1087     my $type = $ctl->[CTL_TYPE];
1088     my $arg;
1089
1090     if ( $type eq '' || $type eq '!' || $type eq '+' ) {
1091         if ( defined $optarg ) {
1092             return (0) if $passthrough;
1093             warn ("Option ", $opt, " does not take an argument\n");
1094             $error++;
1095             undef $opt;
1096             undef $optarg if $bundling_values;
1097         }
1098         elsif ( $type eq '' || $type eq '+' ) {
1099             # Supply explicit value.
1100             $arg = 1;
1101         }
1102         else {
1103             $opt =~ s/^no-?//i; # strip NO prefix
1104             $arg = 0;           # supply explicit value
1105         }
1106         unshift (@$argv, $starter.$rest) if defined $rest;
1107         return (1, $opt, $ctl, $arg);
1108     }
1109
1110     # Get mandatory status and type info.
1111     my $mand = $ctl->[CTL_AMIN];
1112
1113     # Check if there is an option argument available.
1114     if ( $gnu_compat ) {
1115         my $optargtype = 0; # none, 1 = empty, 2 = nonempty, 3 = aux
1116         if ( defined($optarg) ) {
1117             $optargtype = (length($optarg) == 0) ? 1 : 2;
1118         }
1119         elsif ( defined $rest || @$argv > 0 ) {
1120             # GNU getopt_long() does not accept the (optional)
1121             # argument to be passed to the option without = sign.
1122             # We do, since not doing so breaks existing scripts.
1123             $optargtype = 3;
1124         }
1125         if(($optargtype == 0) && !$mand) {
1126             my $val
1127               = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT]
1128               : $type eq 's'                 ? ''
1129               :                                0;
1130             return (1, $opt, $ctl, $val);
1131         }
1132         return (1, $opt, $ctl, $type eq 's' ? '' : 0)
1133           if $optargtype == 1;  # --foo=  -> return nothing
1134     }
1135
1136     # Check if there is an option argument available.
1137     if ( defined $optarg
1138          ? ($optarg eq '')
1139          : !(defined $rest || @$argv > 0) ) {
1140         # Complain if this option needs an argument.
1141 #       if ( $mand && !($type eq 's' ? defined($optarg) : 0) ) {
1142         if ( $mand ) {
1143             return (0) if $passthrough;
1144             warn ("Option ", $opt, " requires an argument\n");
1145             $error++;
1146             return (1, undef);
1147         }
1148         if ( $type eq 'I' ) {
1149             # Fake incremental type.
1150             my @c = @$ctl;
1151             $c[CTL_TYPE] = '+';
1152             return (1, $opt, \@c, 1);
1153         }
1154         return (1, $opt, $ctl,
1155                 defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1156                 $type eq 's' ? '' : 0);
1157     }
1158
1159     # Get (possibly optional) argument.
1160     $arg = (defined $rest ? $rest
1161             : (defined $optarg ? $optarg : shift (@$argv)));
1162
1163     # Get key if this is a "name=value" pair for a hash option.
1164     my $key;
1165     if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
1166         ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
1167           : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1168              ($mand ? undef : ($type eq 's' ? "" : 1)));
1169         if (! defined $arg) {
1170             warn ("Option $opt, key \"$key\", requires a value\n");
1171             $error++;
1172             # Push back.
1173             unshift (@$argv, $starter.$rest) if defined $rest;
1174             return (1, undef);
1175         }
1176     }
1177
1178     #### Check if the argument is valid for this option ####
1179
1180     my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
1181
1182     if ( $type eq 's' ) {       # string
1183         # A mandatory string takes anything.
1184         return (1, $opt, $ctl, $arg, $key) if $mand;
1185
1186         # Same for optional string as a hash value
1187         return (1, $opt, $ctl, $arg, $key)
1188           if $ctl->[CTL_DEST] == CTL_DEST_HASH;
1189
1190         # An optional string takes almost anything.
1191         return (1, $opt, $ctl, $arg, $key)
1192           if defined $optarg || defined $rest;
1193         return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
1194
1195         # Check for option or option list terminator.
1196         if ($arg eq $argend ||
1197             $arg =~ /^$prefix.+/) {
1198             # Push back.
1199             unshift (@$argv, $arg);
1200             # Supply empty value.
1201             $arg = '';
1202         }
1203     }
1204
1205     elsif ( $type eq 'i'        # numeric/integer
1206             || $type eq 'I'     # numeric/integer w/ incr default
1207             || $type eq 'o' ) { # dec/oct/hex/bin value
1208
1209         my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
1210
1211         if ( $bundling && defined $rest
1212              && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
1213             ($key, $arg, $rest) = ($1, $2, $+);
1214             chop($key) if $key;
1215             $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
1216             unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
1217         }
1218         elsif ( $arg =~ /^$o_valid$/si ) {
1219             $arg =~ tr/_//d;
1220             $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
1221         }
1222         else {
1223             if ( defined $optarg || $mand ) {
1224                 if ( $passthrough ) {
1225                     unshift (@$argv, defined $rest ? $starter.$rest : $arg)
1226                       unless defined $optarg;
1227                     return (0);
1228                 }
1229                 warn ("Value \"", $arg, "\" invalid for option ",
1230                       $opt, " (",
1231                       $type eq 'o' ? "extended " : '',
1232                       "number expected)\n");
1233                 $error++;
1234                 # Push back.
1235                 unshift (@$argv, $starter.$rest) if defined $rest;
1236                 return (1, undef);
1237             }
1238             else {
1239                 # Push back.
1240                 unshift (@$argv, defined $rest ? $starter.$rest : $arg);
1241                 if ( $type eq 'I' ) {
1242                     # Fake incremental type.
1243                     my @c = @$ctl;
1244                     $c[CTL_TYPE] = '+';
1245                     return (1, $opt, \@c, 1);
1246                 }
1247                 # Supply default value.
1248                 $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
1249             }
1250         }
1251     }
1252
1253     elsif ( $type eq 'f' ) { # real number, int is also ok
1254         my $o_valid = PAT_FLOAT;
1255         if ( $bundling && defined $rest &&
1256              $rest =~ /^($key_valid)($o_valid)(.*)$/s ) {
1257             $arg =~ tr/_//d;
1258             ($key, $arg, $rest) = ($1, $2, $+);
1259             chop($key) if $key;
1260             unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
1261         }
1262         elsif ( $arg =~ /^$o_valid$/ ) {
1263             $arg =~ tr/_//d;
1264         }
1265         else {
1266             if ( defined $optarg || $mand ) {
1267                 if ( $passthrough ) {
1268                     unshift (@$argv, defined $rest ? $starter.$rest : $arg)
1269                       unless defined $optarg;
1270                     return (0);
1271                 }
1272                 warn ("Value \"", $arg, "\" invalid for option ",
1273                       $opt, " (real number expected)\n");
1274                 $error++;
1275                 # Push back.
1276                 unshift (@$argv, $starter.$rest) if defined $rest;
1277                 return (1, undef);
1278             }
1279             else {
1280                 # Push back.
1281                 unshift (@$argv, defined $rest ? $starter.$rest : $arg);
1282                 # Supply default value.
1283                 $arg = 0.0;
1284             }
1285         }
1286     }
1287     else {
1288         die("Getopt::Long internal error (Can't happen)\n");
1289     }
1290     return (1, $opt, $ctl, $arg, $key);
1291 }
1292
1293 sub ValidValue ($$$$$) {
1294     my ($ctl, $arg, $mand, $argend, $prefix) = @_;
1295
1296     if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
1297         return 0 unless $arg =~ /[^=]+=(.*)/;
1298         $arg = $1;
1299     }
1300
1301     my $type = $ctl->[CTL_TYPE];
1302
1303     if ( $type eq 's' ) {       # string
1304         # A mandatory string takes anything.
1305         return (1) if $mand;
1306
1307         return (1) if $arg eq "-";
1308
1309         # Check for option or option list terminator.
1310         return 0 if $arg eq $argend || $arg =~ /^$prefix.+/;
1311         return 1;
1312     }
1313
1314     elsif ( $type eq 'i'        # numeric/integer
1315             || $type eq 'I'     # numeric/integer w/ incr default
1316             || $type eq 'o' ) { # dec/oct/hex/bin value
1317
1318         my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
1319         return $arg =~ /^$o_valid$/si;
1320     }
1321
1322     elsif ( $type eq 'f' ) { # real number, int is also ok
1323         my $o_valid = PAT_FLOAT;
1324         return $arg =~ /^$o_valid$/;
1325     }
1326     die("ValidValue: Cannot happen\n");
1327 }
1328
1329 # Getopt::Long Configuration.
1330 sub Configure (@) {
1331     my (@options) = @_;
1332
1333     my $prevconfig =
1334       [ $error, $debug, $major_version, $minor_version, $caller,
1335         $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
1336         $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
1337         $longprefix, $bundling_values ];
1338
1339     if ( ref($options[0]) eq 'ARRAY' ) {
1340         ( $error, $debug, $major_version, $minor_version, $caller,
1341           $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
1342           $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
1343           $longprefix, $bundling_values ) = @{shift(@options)};
1344     }
1345
1346     my $opt;
1347     foreach $opt ( @options ) {
1348         my $try = lc ($opt);
1349         my $action = 1;
1350         if ( $try =~ /^no_?(.*)$/s ) {
1351             $action = 0;
1352             $try = $+;
1353         }
1354         if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
1355             ConfigDefaults ();
1356         }
1357         elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
1358             local $ENV{POSIXLY_CORRECT};
1359             $ENV{POSIXLY_CORRECT} = 1 if $action;
1360             ConfigDefaults ();
1361         }
1362         elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
1363             $autoabbrev = $action;
1364         }
1365         elsif ( $try eq 'getopt_compat' ) {
1366             $getopt_compat = $action;
1367             $genprefix = $action ? "(--|-|\\+)" : "(--|-)";
1368         }
1369         elsif ( $try eq 'gnu_getopt' ) {
1370             if ( $action ) {
1371                 $gnu_compat = 1;
1372                 $bundling = 1;
1373                 $getopt_compat = 0;
1374                 $genprefix = "(--|-)";
1375                 $order = $PERMUTE;
1376                 $bundling_values = 0;
1377             }
1378         }
1379         elsif ( $try eq 'gnu_compat' ) {
1380             $gnu_compat = $action;
1381             $bundling = 0;
1382             $bundling_values = 1;
1383         }
1384         elsif ( $try =~ /^(auto_?)?version$/ ) {
1385             $auto_version = $action;
1386         }
1387         elsif ( $try =~ /^(auto_?)?help$/ ) {
1388             $auto_help = $action;
1389         }
1390         elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
1391             $ignorecase = $action;
1392         }
1393         elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) {
1394             $ignorecase = $action ? 2 : 0;
1395         }
1396         elsif ( $try eq 'bundling' ) {
1397             $bundling = $action;
1398             $bundling_values = 0 if $action;
1399         }
1400         elsif ( $try eq 'bundling_override' ) {
1401             $bundling = $action ? 2 : 0;
1402             $bundling_values = 0 if $action;
1403         }
1404         elsif ( $try eq 'bundling_values' ) {
1405             $bundling_values = $action;
1406             $bundling = 0 if $action;
1407         }
1408         elsif ( $try eq 'require_order' ) {
1409             $order = $action ? $REQUIRE_ORDER : $PERMUTE;
1410         }
1411         elsif ( $try eq 'permute' ) {
1412             $order = $action ? $PERMUTE : $REQUIRE_ORDER;
1413         }
1414         elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
1415             $passthrough = $action;
1416         }
1417         elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
1418             $genprefix = $1;
1419             # Turn into regexp. Needs to be parenthesized!
1420             $genprefix = "(" . quotemeta($genprefix) . ")";
1421             eval { '' =~ /$genprefix/; };
1422             die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@;
1423         }
1424         elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
1425             $genprefix = $1;
1426             # Parenthesize if needed.
1427             $genprefix = "(" . $genprefix . ")"
1428               unless $genprefix =~ /^\(.*\)$/;
1429             eval { '' =~ m"$genprefix"; };
1430             die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@;
1431         }
1432         elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) {
1433             $longprefix = $1;
1434             # Parenthesize if needed.
1435             $longprefix = "(" . $longprefix . ")"
1436               unless $longprefix =~ /^\(.*\)$/;
1437             eval { '' =~ m"$longprefix"; };
1438             die("Getopt::Long: invalid long prefix pattern \"$longprefix\"\n") if $@;
1439         }
1440         elsif ( $try eq 'debug' ) {
1441             $debug = $action;
1442         }
1443         else {
1444             die("Getopt::Long: unknown or erroneous config parameter \"$opt\"\n")
1445         }
1446     }
1447     $prevconfig;
1448 }
1449
1450 # Deprecated name.
1451 sub config (@) {
1452     Configure (@_);
1453 }
1454
1455 # Issue a standard message for --version.
1456 #
1457 # The arguments are mostly the same as for Pod::Usage::pod2usage:
1458 #
1459 #  - a number (exit value)
1460 #  - a string (lead in message)
1461 #  - a hash with options. See Pod::Usage for details.
1462 #
1463 sub VersionMessage(@) {
1464     # Massage args.
1465     my $pa = setup_pa_args("version", @_);
1466
1467     my $v = $main::VERSION;
1468     my $fh = $pa->{-output} ||
1469       ( ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR );
1470
1471     print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
1472                $0, defined $v ? " version $v" : (),
1473                "\n",
1474                "(", __PACKAGE__, "::", "GetOptions",
1475                " version ",
1476                defined($Getopt::Long::VERSION_STRING)
1477                  ? $Getopt::Long::VERSION_STRING : $VERSION, ";",
1478                " Perl version ",
1479                $] >= 5.006 ? sprintf("%vd", $^V) : $],
1480                ")\n");
1481     exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT";
1482 }
1483
1484 # Issue a standard message for --help.
1485 #
1486 # The arguments are the same as for Pod::Usage::pod2usage:
1487 #
1488 #  - a number (exit value)
1489 #  - a string (lead in message)
1490 #  - a hash with options. See Pod::Usage for details.
1491 #
1492 sub HelpMessage(@) {
1493     eval {
1494         require Pod::Usage;
1495         import Pod::Usage;
1496         1;
1497     } || die("Cannot provide help: cannot load Pod::Usage\n");
1498
1499     # Note that pod2usage will issue a warning if -exitval => NOEXIT.
1500     pod2usage(setup_pa_args("help", @_));
1501
1502 }
1503
1504 # Helper routine to set up a normalized hash ref to be used as
1505 # argument to pod2usage.
1506 sub setup_pa_args($@) {
1507     my $tag = shift;            # who's calling
1508
1509     # If called by direct binding to an option, it will get the option
1510     # name and value as arguments. Remove these, if so.
1511     @_ = () if @_ == 2 && $_[0] eq $tag;
1512
1513     my $pa;
1514     if ( @_ > 1 ) {
1515         $pa = { @_ };
1516     }
1517     else {
1518         $pa = shift || {};
1519     }
1520
1521     # At this point, $pa can be a number (exit value), string
1522     # (message) or hash with options.
1523
1524     if ( UNIVERSAL::isa($pa, 'HASH') ) {
1525         # Get rid of -msg vs. -message ambiguity.
1526         $pa->{-message} = $pa->{-msg};
1527         delete($pa->{-msg});
1528     }
1529     elsif ( $pa =~ /^-?\d+$/ ) {
1530         $pa = { -exitval => $pa };
1531     }
1532     else {
1533         $pa = { -message => $pa };
1534     }
1535
1536     # These are _our_ defaults.
1537     $pa->{-verbose} = 0 unless exists($pa->{-verbose});
1538     $pa->{-exitval} = 0 unless exists($pa->{-exitval});
1539     $pa;
1540 }
1541
1542 # Sneak way to know what version the user requested.
1543 sub VERSION {
1544     $requested_version = $_[1];
1545     shift->SUPER::VERSION(@_);
1546 }
1547
1548 package Getopt::Long::CallBack;
1549
1550 sub new {
1551     my ($pkg, %atts) = @_;
1552     bless { %atts }, $pkg;
1553 }
1554
1555 sub name {
1556     my $self = shift;
1557     ''.$self->{name};
1558 }
1559
1560 use overload
1561   # Treat this object as an ordinary string for legacy API.
1562   '""'     => \&name,
1563   fallback => 1;
1564
1565 1;
1566
1567 ################ Documentation ################
1568
1569 =head1 NAME
1570
1571 Getopt::Long - Extended processing of command line options
1572
1573 =head1 SYNOPSIS
1574
1575   use Getopt::Long;
1576   my $data   = "file.dat";
1577   my $length = 24;
1578   my $verbose;
1579   GetOptions ("length=i" => \$length,    # numeric
1580               "file=s"   => \$data,      # string
1581               "verbose"  => \$verbose)   # flag
1582   or die("Error in command line arguments\n");
1583
1584 =head1 DESCRIPTION
1585
1586 The Getopt::Long module implements an extended getopt function called
1587 GetOptions(). It parses the command line from C<@ARGV>, recognizing
1588 and removing specified options and their possible values.
1589
1590 This function adheres to the POSIX syntax for command
1591 line options, with GNU extensions. In general, this means that options
1592 have long names instead of single letters, and are introduced with a
1593 double dash "--". Support for bundling of command line options, as was
1594 the case with the more traditional single-letter approach, is provided
1595 but not enabled by default.
1596
1597 =head1 Command Line Options, an Introduction
1598
1599 Command line operated programs traditionally take their arguments from
1600 the command line, for example filenames or other information that the
1601 program needs to know. Besides arguments, these programs often take
1602 command line I<options> as well. Options are not necessary for the
1603 program to work, hence the name 'option', but are used to modify its
1604 default behaviour. For example, a program could do its job quietly,
1605 but with a suitable option it could provide verbose information about
1606 what it did.
1607
1608 Command line options come in several flavours. Historically, they are
1609 preceded by a single dash C<->, and consist of a single letter.
1610
1611     -l -a -c
1612
1613 Usually, these single-character options can be bundled:
1614
1615     -lac
1616
1617 Options can have values, the value is placed after the option
1618 character. Sometimes with whitespace in between, sometimes not:
1619
1620     -s 24 -s24
1621
1622 Due to the very cryptic nature of these options, another style was
1623 developed that used long names. So instead of a cryptic C<-l> one
1624 could use the more descriptive C<--long>. To distinguish between a
1625 bundle of single-character options and a long one, two dashes are used
1626 to precede the option name. Early implementations of long options used
1627 a plus C<+> instead. Also, option values could be specified either
1628 like
1629
1630     --size=24
1631
1632 or
1633
1634     --size 24
1635
1636 The C<+> form is now obsolete and strongly deprecated.
1637
1638 =head1 Getting Started with Getopt::Long
1639
1640 Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was the
1641 first Perl module that provided support for handling the new style of
1642 command line options, in particular long option names, hence the Perl5
1643 name Getopt::Long. This module also supports single-character options
1644 and bundling.
1645
1646 To use Getopt::Long from a Perl program, you must include the
1647 following line in your Perl program:
1648
1649     use Getopt::Long;
1650
1651 This will load the core of the Getopt::Long module and prepare your
1652 program for using it. Most of the actual Getopt::Long code is not
1653 loaded until you really call one of its functions.
1654
1655 In the default configuration, options names may be abbreviated to
1656 uniqueness, case does not matter, and a single dash is sufficient,
1657 even for long option names. Also, options may be placed between
1658 non-option arguments. See L<Configuring Getopt::Long> for more
1659 details on how to configure Getopt::Long.
1660
1661 =head2 Simple options
1662
1663 The most simple options are the ones that take no values. Their mere
1664 presence on the command line enables the option. Popular examples are:
1665
1666     --all --verbose --quiet --debug
1667
1668 Handling simple options is straightforward:
1669
1670     my $verbose = '';   # option variable with default value (false)
1671     my $all = '';       # option variable with default value (false)
1672     GetOptions ('verbose' => \$verbose, 'all' => \$all);
1673
1674 The call to GetOptions() parses the command line arguments that are
1675 present in C<@ARGV> and sets the option variable to the value C<1> if
1676 the option did occur on the command line. Otherwise, the option
1677 variable is not touched. Setting the option value to true is often
1678 called I<enabling> the option.
1679
1680 The option name as specified to the GetOptions() function is called
1681 the option I<specification>. Later we'll see that this specification
1682 can contain more than just the option name. The reference to the
1683 variable is called the option I<destination>.
1684
1685 GetOptions() will return a true value if the command line could be
1686 processed successfully. Otherwise, it will write error messages using
1687 die() and warn(), and return a false result.
1688
1689 =head2 A little bit less simple options
1690
1691 Getopt::Long supports two useful variants of simple options:
1692 I<negatable> options and I<incremental> options.
1693
1694 A negatable option is specified with an exclamation mark C<!> after the
1695 option name:
1696
1697     my $verbose = '';   # option variable with default value (false)
1698     GetOptions ('verbose!' => \$verbose);
1699
1700 Now, using C<--verbose> on the command line will enable C<$verbose>,
1701 as expected. But it is also allowed to use C<--noverbose>, which will
1702 disable C<$verbose> by setting its value to C<0>. Using a suitable
1703 default value, the program can find out whether C<$verbose> is false
1704 by default, or disabled by using C<--noverbose>.
1705
1706 An incremental option is specified with a plus C<+> after the
1707 option name:
1708
1709     my $verbose = '';   # option variable with default value (false)
1710     GetOptions ('verbose+' => \$verbose);
1711
1712 Using C<--verbose> on the command line will increment the value of
1713 C<$verbose>. This way the program can keep track of how many times the
1714 option occurred on the command line. For example, each occurrence of
1715 C<--verbose> could increase the verbosity level of the program.
1716
1717 =head2 Mixing command line option with other arguments
1718
1719 Usually programs take command line options as well as other arguments,
1720 for example, file names. It is good practice to always specify the
1721 options first, and the other arguments last. Getopt::Long will,
1722 however, allow the options and arguments to be mixed and 'filter out'
1723 all the options before passing the rest of the arguments to the
1724 program. To stop Getopt::Long from processing further arguments,
1725 insert a double dash C<--> on the command line:
1726
1727     --size 24 -- --all
1728
1729 In this example, C<--all> will I<not> be treated as an option, but
1730 passed to the program unharmed, in C<@ARGV>.
1731
1732 =head2 Options with values
1733
1734 For options that take values it must be specified whether the option
1735 value is required or not, and what kind of value the option expects.
1736
1737 Three kinds of values are supported: integer numbers, floating point
1738 numbers, and strings.
1739
1740 If the option value is required, Getopt::Long will take the
1741 command line argument that follows the option and assign this to the
1742 option variable. If, however, the option value is specified as
1743 optional, this will only be done if that value does not look like a
1744 valid command line option itself.
1745
1746     my $tag = '';       # option variable with default value
1747     GetOptions ('tag=s' => \$tag);
1748
1749 In the option specification, the option name is followed by an equals
1750 sign C<=> and the letter C<s>. The equals sign indicates that this
1751 option requires a value. The letter C<s> indicates that this value is
1752 an arbitrary string. Other possible value types are C<i> for integer
1753 values, and C<f> for floating point values. Using a colon C<:> instead
1754 of the equals sign indicates that the option value is optional. In
1755 this case, if no suitable value is supplied, string valued options get
1756 an empty string C<''> assigned, while numeric options are set to C<0>.
1757
1758 =head2 Options with multiple values
1759
1760 Options sometimes take several values. For example, a program could
1761 use multiple directories to search for library files:
1762
1763     --library lib/stdlib --library lib/extlib
1764
1765 To accomplish this behaviour, simply specify an array reference as the
1766 destination for the option:
1767
1768     GetOptions ("library=s" => \@libfiles);
1769
1770 Alternatively, you can specify that the option can have multiple
1771 values by adding a "@", and pass a reference to a scalar as the
1772 destination:
1773
1774     GetOptions ("library=s@" => \$libfiles);
1775
1776 Used with the example above, C<@libfiles> c.q. C<@$libfiles> would
1777 contain two strings upon completion: C<"lib/stdlib"> and
1778 C<"lib/extlib">, in that order. It is also possible to specify that
1779 only integer or floating point numbers are acceptable values.
1780
1781 Often it is useful to allow comma-separated lists of values as well as
1782 multiple occurrences of the options. This is easy using Perl's split()
1783 and join() operators:
1784
1785     GetOptions ("library=s" => \@libfiles);
1786     @libfiles = split(/,/,join(',',@libfiles));
1787
1788 Of course, it is important to choose the right separator string for
1789 each purpose.
1790
1791 Warning: What follows is an experimental feature.
1792
1793 Options can take multiple values at once, for example
1794
1795     --coordinates 52.2 16.4 --rgbcolor 255 255 149
1796
1797 This can be accomplished by adding a repeat specifier to the option
1798 specification. Repeat specifiers are very similar to the C<{...}>
1799 repeat specifiers that can be used with regular expression patterns.
1800 For example, the above command line would be handled as follows:
1801
1802     GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color);
1803
1804 The destination for the option must be an array or array reference.
1805
1806 It is also possible to specify the minimal and maximal number of
1807 arguments an option takes. C<foo=s{2,4}> indicates an option that
1808 takes at least two and at most 4 arguments. C<foo=s{1,}> indicates one
1809 or more values; C<foo:s{,}> indicates zero or more option values.
1810
1811 =head2 Options with hash values
1812
1813 If the option destination is a reference to a hash, the option will
1814 take, as value, strings of the form I<key>C<=>I<value>. The value will
1815 be stored with the specified key in the hash.
1816
1817     GetOptions ("define=s" => \%defines);
1818
1819 Alternatively you can use:
1820
1821     GetOptions ("define=s%" => \$defines);
1822
1823 When used with command line options:
1824
1825     --define os=linux --define vendor=redhat
1826
1827 the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os">
1828 with value C<"linux"> and C<"vendor"> with value C<"redhat">. It is
1829 also possible to specify that only integer or floating point numbers
1830 are acceptable values. The keys are always taken to be strings.
1831
1832 =head2 User-defined subroutines to handle options
1833
1834 Ultimate control over what should be done when (actually: each time)
1835 an option is encountered on the command line can be achieved by
1836 designating a reference to a subroutine (or an anonymous subroutine)
1837 as the option destination. When GetOptions() encounters the option, it
1838 will call the subroutine with two or three arguments. The first
1839 argument is the name of the option. (Actually, it is an object that
1840 stringifies to the name of the option.) For a scalar or array destination,
1841 the second argument is the value to be stored. For a hash destination,
1842 the second argument is the key to the hash, and the third argument
1843 the value to be stored. It is up to the subroutine to store the value,
1844 or do whatever it thinks is appropriate.
1845
1846 A trivial application of this mechanism is to implement options that
1847 are related to each other. For example:
1848
1849     my $verbose = '';   # option variable with default value (false)
1850     GetOptions ('verbose' => \$verbose,
1851                 'quiet'   => sub { $verbose = 0 });
1852
1853 Here C<--verbose> and C<--quiet> control the same variable
1854 C<$verbose>, but with opposite values.
1855
1856 If the subroutine needs to signal an error, it should call die() with
1857 the desired error message as its argument. GetOptions() will catch the
1858 die(), issue the error message, and record that an error result must
1859 be returned upon completion.
1860
1861 If the text of the error message starts with an exclamation mark C<!>
1862 it is interpreted specially by GetOptions(). There is currently one
1863 special command implemented: C<die("!FINISH")> will cause GetOptions()
1864 to stop processing options, as if it encountered a double dash C<-->.
1865
1866 In version 2.37 the first argument to the callback function was
1867 changed from string to object. This was done to make room for
1868 extensions and more detailed control. The object stringifies to the
1869 option name so this change should not introduce compatibility
1870 problems.
1871
1872 Here is an example of how to access the option name and value from within
1873 a subroutine:
1874
1875     GetOptions ('opt=i' => \&handler);
1876     sub handler {
1877         my ($opt_name, $opt_value) = @_;
1878         print("Option name is $opt_name and value is $opt_value\n");
1879     }
1880
1881 =head2 Options with multiple names
1882
1883 Often it is user friendly to supply alternate mnemonic names for
1884 options. For example C<--height> could be an alternate name for
1885 C<--length>. Alternate names can be included in the option
1886 specification, separated by vertical bar C<|> characters. To implement
1887 the above example:
1888
1889     GetOptions ('length|height=f' => \$length);
1890
1891 The first name is called the I<primary> name, the other names are
1892 called I<aliases>. When using a hash to store options, the key will
1893 always be the primary name.
1894
1895 Multiple alternate names are possible.
1896
1897 =head2 Case and abbreviations
1898
1899 Without additional configuration, GetOptions() will ignore the case of
1900 option names, and allow the options to be abbreviated to uniqueness.
1901
1902     GetOptions ('length|height=f' => \$length, "head" => \$head);
1903
1904 This call will allow C<--l> and C<--L> for the length option, but
1905 requires a least C<--hea> and C<--hei> for the head and height options.
1906
1907 =head2 Summary of Option Specifications
1908
1909 Each option specifier consists of two parts: the name specification
1910 and the argument specification.
1911
1912 The name specification contains the name of the option, optionally
1913 followed by a list of alternative names separated by vertical bar
1914 characters.
1915
1916     length            option name is "length"
1917     length|size|l     name is "length", aliases are "size" and "l"
1918
1919 The argument specification is optional. If omitted, the option is
1920 considered boolean, a value of 1 will be assigned when the option is
1921 used on the command line.
1922
1923 The argument specification can be
1924
1925 =over 4
1926
1927 =item !
1928
1929 The option does not take an argument and may be negated by prefixing
1930 it with "no" or "no-". E.g. C<"foo!"> will allow C<--foo> (a value of
1931 1 will be assigned) as well as C<--nofoo> and C<--no-foo> (a value of
1932 0 will be assigned). If the option has aliases, this applies to the
1933 aliases as well.
1934
1935 Using negation on a single letter option when bundling is in effect is
1936 pointless and will result in a warning.
1937
1938 =item +
1939
1940 The option does not take an argument and will be incremented by 1
1941 every time it appears on the command line. E.g. C<"more+">, when used
1942 with C<--more --more --more>, will increment the value three times,
1943 resulting in a value of 3 (provided it was 0 or undefined at first).
1944
1945 The C<+> specifier is ignored if the option destination is not a scalar.
1946
1947 =item = I<type> [ I<desttype> ] [ I<repeat> ]
1948
1949 The option requires an argument of the given type. Supported types
1950 are:
1951
1952 =over 4
1953
1954 =item s
1955
1956 String. An arbitrary sequence of characters. It is valid for the
1957 argument to start with C<-> or C<-->.
1958
1959 =item i
1960
1961 Integer. An optional leading plus or minus sign, followed by a
1962 sequence of digits.
1963
1964 =item o
1965
1966 Extended integer, Perl style. This can be either an optional leading
1967 plus or minus sign, followed by a sequence of digits, or an octal
1968 string (a zero, optionally followed by '0', '1', .. '7'), or a
1969 hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case
1970 insensitive), or a binary string (C<0b> followed by a series of '0'
1971 and '1').
1972
1973 =item f
1974
1975 Real number. For example C<3.14>, C<-6.23E24> and so on.
1976
1977 =back
1978
1979 The I<desttype> can be C<@> or C<%> to specify that the option is
1980 list or a hash valued. This is only needed when the destination for
1981 the option value is not otherwise specified. It should be omitted when
1982 not needed.
1983
1984 The I<repeat> specifies the number of values this option takes per
1985 occurrence on the command line. It has the format C<{> [ I<min> ] [ C<,> [ I<max> ] ] C<}>.
1986
1987 I<min> denotes the minimal number of arguments. It defaults to 1 for
1988 options with C<=> and to 0 for options with C<:>, see below. Note that
1989 I<min> overrules the C<=> / C<:> semantics.
1990
1991 I<max> denotes the maximum number of arguments. It must be at least
1992 I<min>. If I<max> is omitted, I<but the comma is not>, there is no
1993 upper bound to the number of argument values taken.
1994
1995 =item : I<type> [ I<desttype> ]
1996
1997 Like C<=>, but designates the argument as optional.
1998 If omitted, an empty string will be assigned to string values options,
1999 and the value zero to numeric options.
2000
2001 Note that if a string argument starts with C<-> or C<-->, it will be
2002 considered an option on itself.
2003
2004 =item : I<number> [ I<desttype> ]
2005
2006 Like C<:i>, but if the value is omitted, the I<number> will be assigned.
2007
2008 =item : + [ I<desttype> ]
2009
2010 Like C<:i>, but if the value is omitted, the current value for the
2011 option will be incremented.
2012
2013 =back
2014
2015 =head1 Advanced Possibilities
2016
2017 =head2 Object oriented interface
2018
2019 Getopt::Long can be used in an object oriented way as well:
2020
2021     use Getopt::Long;
2022     $p = Getopt::Long::Parser->new;
2023     $p->configure(...configuration options...);
2024     if ($p->getoptions(...options descriptions...)) ...
2025     if ($p->getoptionsfromarray( \@array, ...options descriptions...)) ...
2026
2027 Configuration options can be passed to the constructor:
2028
2029     $p = new Getopt::Long::Parser
2030              config => [...configuration options...];
2031
2032 =head2 Thread Safety
2033
2034 Getopt::Long is thread safe when using ithreads as of Perl 5.8.  It is
2035 I<not> thread safe when using the older (experimental and now
2036 obsolete) threads implementation that was added to Perl 5.005.
2037
2038 =head2 Documentation and help texts
2039
2040 Getopt::Long encourages the use of Pod::Usage to produce help
2041 messages. For example:
2042
2043     use Getopt::Long;
2044     use Pod::Usage;
2045
2046     my $man = 0;
2047     my $help = 0;
2048
2049     GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
2050     pod2usage(1) if $help;
2051     pod2usage(-exitval => 0, -verbose => 2) if $man;
2052
2053     __END__
2054
2055     =head1 NAME
2056
2057     sample - Using Getopt::Long and Pod::Usage
2058
2059     =head1 SYNOPSIS
2060
2061     sample [options] [file ...]
2062
2063      Options:
2064        -help            brief help message
2065        -man             full documentation
2066
2067     =head1 OPTIONS
2068
2069     =over 8
2070
2071     =item B<-help>
2072
2073     Print a brief help message and exits.
2074
2075     =item B<-man>
2076
2077     Prints the manual page and exits.
2078
2079     =back
2080
2081     =head1 DESCRIPTION
2082
2083     B<This program> will read the given input file(s) and do something
2084     useful with the contents thereof.
2085
2086     =cut
2087
2088 See L<Pod::Usage> for details.
2089
2090 =head2 Parsing options from an arbitrary array
2091
2092 By default, GetOptions parses the options that are present in the
2093 global array C<@ARGV>. A special entry C<GetOptionsFromArray> can be
2094 used to parse options from an arbitrary array.
2095
2096     use Getopt::Long qw(GetOptionsFromArray);
2097     $ret = GetOptionsFromArray(\@myopts, ...);
2098
2099 When used like this, options and their possible values are removed
2100 from C<@myopts>, the global C<@ARGV> is not touched at all.
2101
2102 The following two calls behave identically:
2103
2104     $ret = GetOptions( ... );
2105     $ret = GetOptionsFromArray(\@ARGV, ... );
2106
2107 This also means that a first argument hash reference now becomes the
2108 second argument:
2109
2110     $ret = GetOptions(\%opts, ... );
2111     $ret = GetOptionsFromArray(\@ARGV, \%opts, ... );
2112
2113 =head2 Parsing options from an arbitrary string
2114
2115 A special entry C<GetOptionsFromString> can be used to parse options
2116 from an arbitrary string.
2117
2118     use Getopt::Long qw(GetOptionsFromString);
2119     $ret = GetOptionsFromString($string, ...);
2120
2121 The contents of the string are split into arguments using a call to
2122 C<Text::ParseWords::shellwords>. As with C<GetOptionsFromArray>, the
2123 global C<@ARGV> is not touched.
2124
2125 It is possible that, upon completion, not all arguments in the string
2126 have been processed. C<GetOptionsFromString> will, when called in list
2127 context, return both the return status and an array reference to any
2128 remaining arguments:
2129
2130     ($ret, $args) = GetOptionsFromString($string, ... );
2131
2132 If any arguments remain, and C<GetOptionsFromString> was not called in
2133 list context, a message will be given and C<GetOptionsFromString> will
2134 return failure.
2135
2136 As with GetOptionsFromArray, a first argument hash reference now
2137 becomes the second argument.
2138
2139 =head2 Storing options values in a hash
2140
2141 Sometimes, for example when there are a lot of options, having a
2142 separate variable for each of them can be cumbersome. GetOptions()
2143 supports, as an alternative mechanism, storing options values in a
2144 hash.
2145
2146 To obtain this, a reference to a hash must be passed I<as the first
2147 argument> to GetOptions(). For each option that is specified on the
2148 command line, the option value will be stored in the hash with the
2149 option name as key. Options that are not actually used on the command
2150 line will not be put in the hash, on other words,
2151 C<exists($h{option})> (or defined()) can be used to test if an option
2152 was used. The drawback is that warnings will be issued if the program
2153 runs under C<use strict> and uses C<$h{option}> without testing with
2154 exists() or defined() first.
2155
2156     my %h = ();
2157     GetOptions (\%h, 'length=i');       # will store in $h{length}
2158
2159 For options that take list or hash values, it is necessary to indicate
2160 this by appending an C<@> or C<%> sign after the type:
2161
2162     GetOptions (\%h, 'colours=s@');     # will push to @{$h{colours}}
2163
2164 To make things more complicated, the hash may contain references to
2165 the actual destinations, for example:
2166
2167     my $len = 0;
2168     my %h = ('length' => \$len);
2169     GetOptions (\%h, 'length=i');       # will store in $len
2170
2171 This example is fully equivalent with:
2172
2173     my $len = 0;
2174     GetOptions ('length=i' => \$len);   # will store in $len
2175
2176 Any mixture is possible. For example, the most frequently used options
2177 could be stored in variables while all other options get stored in the
2178 hash:
2179
2180     my $verbose = 0;                    # frequently referred
2181     my $debug = 0;                      # frequently referred
2182     my %h = ('verbose' => \$verbose, 'debug' => \$debug);
2183     GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i');
2184     if ( $verbose ) { ... }
2185     if ( exists $h{filter} ) { ... option 'filter' was specified ... }
2186
2187 =head2 Bundling
2188
2189 With bundling it is possible to set several single-character options
2190 at once. For example if C<a>, C<v> and C<x> are all valid options,
2191
2192     -vax
2193
2194 will set all three.
2195
2196 Getopt::Long supports three styles of bundling. To enable bundling, a
2197 call to Getopt::Long::Configure is required.
2198
2199 The simplest style of bundling can be enabled with:
2200
2201     Getopt::Long::Configure ("bundling");
2202
2203 Configured this way, single-character options can be bundled but long
2204 options B<must> always start with a double dash C<--> to avoid
2205 ambiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid
2206 options,
2207
2208     -vax
2209
2210 will set C<a>, C<v> and C<x>, but
2211
2212     --vax
2213
2214 will set C<vax>.
2215
2216 The second style of bundling lifts this restriction. It can be enabled
2217 with:
2218
2219     Getopt::Long::Configure ("bundling_override");
2220
2221 Now, C<-vax> will set the option C<vax>.
2222
2223 In all of the above cases, option values may be inserted in the
2224 bundle. For example:
2225
2226     -h24w80
2227
2228 is equivalent to
2229
2230     -h 24 -w 80
2231
2232 A third style of bundling allows only values to be bundled with
2233 options. It can be enabled with:
2234
2235     Getopt::Long::Configure ("bundling_values");
2236
2237 Now, C<-h24> will set the option C<h> to C<24>, but option bundles
2238 like C<-vxa> and C<-h24w80> are flagged as errors.
2239
2240 Enabling C<bundling_values> will disable the other two styles of
2241 bundling.
2242
2243 When configured for bundling, single-character options are matched
2244 case sensitive while long options are matched case insensitive. To
2245 have the single-character options matched case insensitive as well,
2246 use:
2247
2248     Getopt::Long::Configure ("bundling", "ignorecase_always");
2249
2250 It goes without saying that bundling can be quite confusing.
2251
2252 =head2 The lonesome dash
2253
2254 Normally, a lone dash C<-> on the command line will not be considered
2255 an option. Option processing will terminate (unless "permute" is
2256 configured) and the dash will be left in C<@ARGV>.
2257
2258 It is possible to get special treatment for a lone dash. This can be
2259 achieved by adding an option specification with an empty name, for
2260 example:
2261
2262     GetOptions ('' => \$stdio);
2263
2264 A lone dash on the command line will now be a legal option, and using
2265 it will set variable C<$stdio>.
2266
2267 =head2 Argument callback
2268
2269 A special option 'name' C<< <> >> can be used to designate a subroutine
2270 to handle non-option arguments. When GetOptions() encounters an
2271 argument that does not look like an option, it will immediately call this
2272 subroutine and passes it one parameter: the argument name. Well, actually
2273 it is an object that stringifies to the argument name.
2274
2275 For example:
2276
2277     my $width = 80;
2278     sub process { ... }
2279     GetOptions ('width=i' => \$width, '<>' => \&process);
2280
2281 When applied to the following command line:
2282
2283     arg1 --width=72 arg2 --width=60 arg3
2284
2285 This will call
2286 C<process("arg1")> while C<$width> is C<80>,
2287 C<process("arg2")> while C<$width> is C<72>, and
2288 C<process("arg3")> while C<$width> is C<60>.
2289
2290 This feature requires configuration option B<permute>, see section
2291 L<Configuring Getopt::Long>.
2292
2293 =head1 Configuring Getopt::Long
2294
2295 Getopt::Long can be configured by calling subroutine
2296 Getopt::Long::Configure(). This subroutine takes a list of quoted
2297 strings, each specifying a configuration option to be enabled, e.g.
2298 C<ignore_case>, or disabled, e.g. C<no_ignore_case>. Case does not
2299 matter. Multiple calls to Configure() are possible.
2300
2301 Alternatively, as of version 2.24, the configuration options may be
2302 passed together with the C<use> statement:
2303
2304     use Getopt::Long qw(:config no_ignore_case bundling);
2305
2306 The following options are available:
2307
2308 =over 12
2309
2310 =item default
2311
2312 This option causes all configuration options to be reset to their
2313 default values.
2314
2315 =item posix_default
2316
2317 This option causes all configuration options to be reset to their
2318 default values as if the environment variable POSIXLY_CORRECT had
2319 been set.
2320
2321 =item auto_abbrev
2322
2323 Allow option names to be abbreviated to uniqueness.
2324 Default is enabled unless environment variable
2325 POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled.
2326
2327 =item getopt_compat
2328
2329 Allow C<+> to start options.
2330 Default is enabled unless environment variable
2331 POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled.
2332
2333 =item gnu_compat
2334
2335 C<gnu_compat> controls whether C<--opt=> is allowed, and what it should
2336 do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>,
2337 C<--opt=> will give option C<opt> and empty value.
2338 This is the way GNU getopt_long() does it.
2339
2340 Note that C<--opt value> is still accepted, even though GNU
2341 getopt_long() doesn't.
2342
2343 =item gnu_getopt
2344
2345 This is a short way of setting C<gnu_compat> C<bundling> C<permute>
2346 C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be
2347 reasonably compatible with GNU getopt_long().
2348
2349 =item require_order
2350
2351 Whether command line arguments are allowed to be mixed with options.
2352 Default is disabled unless environment variable
2353 POSIXLY_CORRECT has been set, in which case C<require_order> is enabled.
2354
2355 See also C<permute>, which is the opposite of C<require_order>.
2356
2357 =item permute
2358
2359 Whether command line arguments are allowed to be mixed with options.
2360 Default is enabled unless environment variable
2361 POSIXLY_CORRECT has been set, in which case C<permute> is disabled.
2362 Note that C<permute> is the opposite of C<require_order>.
2363
2364 If C<permute> is enabled, this means that
2365
2366     --foo arg1 --bar arg2 arg3
2367
2368 is equivalent to
2369
2370     --foo --bar arg1 arg2 arg3
2371
2372 If an argument callback routine is specified, C<@ARGV> will always be
2373 empty upon successful return of GetOptions() since all options have been
2374 processed. The only exception is when C<--> is used:
2375
2376     --foo arg1 --bar arg2 -- arg3
2377
2378 This will call the callback routine for arg1 and arg2, and then
2379 terminate GetOptions() leaving C<"arg3"> in C<@ARGV>.
2380
2381 If C<require_order> is enabled, options processing
2382 terminates when the first non-option is encountered.
2383
2384     --foo arg1 --bar arg2 arg3
2385
2386 is equivalent to
2387
2388     --foo -- arg1 --bar arg2 arg3
2389
2390 If C<pass_through> is also enabled, options processing will terminate
2391 at the first unrecognized option, or non-option, whichever comes
2392 first.
2393
2394 =item bundling (default: disabled)
2395
2396 Enabling this option will allow single-character options to be
2397 bundled. To distinguish bundles from long option names, long options
2398 I<must> be introduced with C<--> and bundles with C<->.
2399
2400 Note that, if you have options C<a>, C<l> and C<all>, and
2401 auto_abbrev enabled, possible arguments and option settings are:
2402
2403     using argument               sets option(s)
2404     ------------------------------------------
2405     -a, --a                      a
2406     -l, --l                      l
2407     -al, -la, -ala, -all,...     a, l
2408     --al, --all                  all
2409
2410 The surprising part is that C<--a> sets option C<a> (due to auto
2411 completion), not C<all>.
2412
2413 Note: disabling C<bundling> also disables C<bundling_override>.
2414
2415 =item bundling_override (default: disabled)
2416
2417 If C<bundling_override> is enabled, bundling is enabled as with
2418 C<bundling> but now long option names override option bundles.
2419
2420 Note: disabling C<bundling_override> also disables C<bundling>.
2421
2422 B<Note:> Using option bundling can easily lead to unexpected results,
2423 especially when mixing long options and bundles. Caveat emptor.
2424
2425 =item ignore_case  (default: enabled)
2426
2427 If enabled, case is ignored when matching option names. If, however,
2428 bundling is enabled as well, single character options will be treated
2429 case-sensitive.
2430
2431 With C<ignore_case>, option specifications for options that only
2432 differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as
2433 duplicates.
2434
2435 Note: disabling C<ignore_case> also disables C<ignore_case_always>.
2436
2437 =item ignore_case_always (default: disabled)
2438
2439 When bundling is in effect, case is ignored on single-character
2440 options also.
2441
2442 Note: disabling C<ignore_case_always> also disables C<ignore_case>.
2443
2444 =item auto_version (default:disabled)
2445
2446 Automatically provide support for the B<--version> option if
2447 the application did not specify a handler for this option itself.
2448
2449 Getopt::Long will provide a standard version message that includes the
2450 program name, its version (if $main::VERSION is defined), and the
2451 versions of Getopt::Long and Perl. The message will be written to
2452 standard output and processing will terminate.
2453
2454 C<auto_version> will be enabled if the calling program explicitly
2455 specified a version number higher than 2.32 in the C<use> or
2456 C<require> statement.
2457
2458 =item auto_help (default:disabled)
2459
2460 Automatically provide support for the B<--help> and B<-?> options if
2461 the application did not specify a handler for this option itself.
2462
2463 Getopt::Long will provide a help message using module L<Pod::Usage>. The
2464 message, derived from the SYNOPSIS POD section, will be written to
2465 standard output and processing will terminate.
2466
2467 C<auto_help> will be enabled if the calling program explicitly
2468 specified a version number higher than 2.32 in the C<use> or
2469 C<require> statement.
2470
2471 =item pass_through (default: disabled)
2472
2473 With C<pass_through> anything that is unknown, ambiguous or supplied with
2474 an invalid option will not be flagged as an error. Instead the unknown
2475 option(s) will be passed to the catchall C<< <> >> if present, otherwise
2476 through to C<@ARGV>. This makes it possible to write wrapper scripts that
2477 process only part of the user supplied command line arguments, and pass the
2478 remaining options to some other program.
2479
2480 If C<require_order> is enabled, options processing will terminate at the
2481 first unrecognized option, or non-option, whichever comes first and all
2482 remaining arguments are passed to C<@ARGV> instead of the catchall
2483 C<< <> >> if present.  However, if C<permute> is enabled instead, results
2484 can become confusing.
2485
2486 Note that the options terminator (default C<-->), if present, will
2487 also be passed through in C<@ARGV>.
2488
2489 =item prefix
2490
2491 The string that starts options. If a constant string is not
2492 sufficient, see C<prefix_pattern>.
2493
2494 =item prefix_pattern
2495
2496 A Perl pattern that identifies the strings that introduce options.
2497 Default is C<--|-|\+> unless environment variable
2498 POSIXLY_CORRECT has been set, in which case it is C<--|->.
2499
2500 =item long_prefix_pattern
2501
2502 A Perl pattern that allows the disambiguation of long and short
2503 prefixes. Default is C<-->.
2504
2505 Typically you only need to set this if you are using nonstandard
2506 prefixes and want some or all of them to have the same semantics as
2507 '--' does under normal circumstances.
2508
2509 For example, setting prefix_pattern to C<--|-|\+|\/> and
2510 long_prefix_pattern to C<--|\/> would add Win32 style argument
2511 handling.
2512
2513 =item debug (default: disabled)
2514
2515 Enable debugging output.
2516
2517 =back
2518
2519 =head1 Exportable Methods
2520
2521 =over
2522
2523 =item VersionMessage
2524
2525 This subroutine provides a standard version message. Its argument can be:
2526
2527 =over 4
2528
2529 =item *
2530
2531 A string containing the text of a message to print I<before> printing
2532 the standard message.
2533
2534 =item *
2535
2536 A numeric value corresponding to the desired exit status.
2537
2538 =item *
2539
2540 A reference to a hash.
2541
2542 =back
2543
2544 If more than one argument is given then the entire argument list is
2545 assumed to be a hash.  If a hash is supplied (either as a reference or
2546 as a list) it should contain one or more elements with the following
2547 keys:
2548
2549 =over 4
2550
2551 =item C<-message>
2552
2553 =item C<-msg>
2554
2555 The text of a message to print immediately prior to printing the
2556 program's usage message.
2557
2558 =item C<-exitval>
2559
2560 The desired exit status to pass to the B<exit()> function.
2561 This should be an integer, or else the string "NOEXIT" to
2562 indicate that control should simply be returned without
2563 terminating the invoking process.
2564
2565 =item C<-output>
2566
2567 A reference to a filehandle, or the pathname of a file to which the
2568 usage message should be written. The default is C<\*STDERR> unless the
2569 exit value is less than 2 (in which case the default is C<\*STDOUT>).
2570
2571 =back
2572
2573 You cannot tie this routine directly to an option, e.g.:
2574
2575     GetOptions("version" => \&VersionMessage);
2576
2577 Use this instead:
2578
2579     GetOptions("version" => sub { VersionMessage() });
2580
2581 =item HelpMessage
2582
2583 This subroutine produces a standard help message, derived from the
2584 program's POD section SYNOPSIS using L<Pod::Usage>. It takes the same
2585 arguments as VersionMessage(). In particular, you cannot tie it
2586 directly to an option, e.g.:
2587
2588     GetOptions("help" => \&HelpMessage);
2589
2590 Use this instead:
2591
2592     GetOptions("help" => sub { HelpMessage() });
2593
2594 =back
2595
2596 =head1 Return values and Errors
2597
2598 Configuration errors and errors in the option definitions are
2599 signalled using die() and will terminate the calling program unless
2600 the call to Getopt::Long::GetOptions() was embedded in C<eval { ...
2601 }>, or die() was trapped using C<$SIG{__DIE__}>.
2602
2603 GetOptions returns true to indicate success.
2604 It returns false when the function detected one or more errors during
2605 option parsing. These errors are signalled using warn() and can be
2606 trapped with C<$SIG{__WARN__}>.
2607
2608 =head1 Legacy
2609
2610 The earliest development of C<newgetopt.pl> started in 1990, with Perl
2611 version 4. As a result, its development, and the development of
2612 Getopt::Long, has gone through several stages. Since backward
2613 compatibility has always been extremely important, the current version
2614 of Getopt::Long still supports a lot of constructs that nowadays are
2615 no longer necessary or otherwise unwanted. This section describes
2616 briefly some of these 'features'.
2617
2618 =head2 Default destinations
2619
2620 When no destination is specified for an option, GetOptions will store
2621 the resultant value in a global variable named C<opt_>I<XXX>, where
2622 I<XXX> is the primary name of this option. When a program executes
2623 under C<use strict> (recommended), these variables must be
2624 pre-declared with our() or C<use vars>.
2625
2626     our $opt_length = 0;
2627     GetOptions ('length=i');    # will store in $opt_length
2628
2629 To yield a usable Perl variable, characters that are not part of the
2630 syntax for variables are translated to underscores. For example,
2631 C<--fpp-struct-return> will set the variable
2632 C<$opt_fpp_struct_return>. Note that this variable resides in the
2633 namespace of the calling program, not necessarily C<main>. For
2634 example:
2635
2636     GetOptions ("size=i", "sizes=i@");
2637
2638 with command line "-size 10 -sizes 24 -sizes 48" will perform the
2639 equivalent of the assignments
2640
2641     $opt_size = 10;
2642     @opt_sizes = (24, 48);
2643
2644 =head2 Alternative option starters
2645
2646 A string of alternative option starter characters may be passed as the
2647 first argument (or the first argument after a leading hash reference
2648 argument).
2649
2650     my $len = 0;
2651     GetOptions ('/', 'length=i' => $len);
2652
2653 Now the command line may look like:
2654
2655     /length 24 -- arg
2656
2657 Note that to terminate options processing still requires a double dash
2658 C<-->.
2659
2660 GetOptions() will not interpret a leading C<< "<>" >> as option starters
2661 if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as
2662 option starters, use C<< "><" >>. Confusing? Well, B<using a starter
2663 argument is strongly deprecated> anyway.
2664
2665 =head2 Configuration variables
2666
2667 Previous versions of Getopt::Long used variables for the purpose of
2668 configuring. Although manipulating these variables still work, it is
2669 strongly encouraged to use the C<Configure> routine that was introduced
2670 in version 2.17. Besides, it is much easier.
2671
2672 =head1 Tips and Techniques
2673
2674 =head2 Pushing multiple values in a hash option
2675
2676 Sometimes you want to combine the best of hashes and arrays. For
2677 example, the command line:
2678
2679   --list add=first --list add=second --list add=third
2680
2681 where each successive 'list add' option will push the value of add
2682 into array ref $list->{'add'}. The result would be like
2683
2684   $list->{add} = [qw(first second third)];
2685
2686 This can be accomplished with a destination routine:
2687
2688   GetOptions('list=s%' =>
2689                sub { push(@{$list{$_[1]}}, $_[2]) });
2690
2691 =head1 Troubleshooting
2692
2693 =head2 GetOptions does not return a false result when an option is not supplied
2694
2695 That's why they're called 'options'.
2696
2697 =head2 GetOptions does not split the command line correctly
2698
2699 The command line is not split by GetOptions, but by the command line
2700 interpreter (CLI). On Unix, this is the shell. On Windows, it is
2701 COMMAND.COM or CMD.EXE. Other operating systems have other CLIs.
2702
2703 It is important to know that these CLIs may behave different when the
2704 command line contains special characters, in particular quotes or
2705 backslashes. For example, with Unix shells you can use single quotes
2706 (C<'>) and double quotes (C<">) to group words together. The following
2707 alternatives are equivalent on Unix:
2708
2709     "two words"
2710     'two words'
2711     two\ words
2712
2713 In case of doubt, insert the following statement in front of your Perl
2714 program:
2715
2716     print STDERR (join("|",@ARGV),"\n");
2717
2718 to verify how your CLI passes the arguments to the program.
2719
2720 =head2 Undefined subroutine &main::GetOptions called
2721
2722 Are you running Windows, and did you write
2723
2724     use GetOpt::Long;
2725
2726 (note the capital 'O')?
2727
2728 =head2 How do I put a "-?" option into a Getopt::Long?
2729
2730 You can only obtain this using an alias, and Getopt::Long of at least
2731 version 2.13.
2732
2733     use Getopt::Long;
2734     GetOptions ("help|?");    # -help and -? will both set $opt_help
2735
2736 Other characters that can't appear in Perl identifiers are also supported
2737 as aliases with Getopt::Long of at least version 2.39.
2738
2739 As of version 2.32 Getopt::Long provides auto-help, a quick and easy way
2740 to add the options --help and -? to your program, and handle them.
2741
2742 See C<auto_help> in section L<Configuring Getopt::Long>.
2743
2744 =head1 AUTHOR
2745
2746 Johan Vromans <jvromans@squirrel.nl>
2747
2748 =head1 COPYRIGHT AND DISCLAIMER
2749
2750 This program is Copyright 1990,2015 by Johan Vromans.
2751 This program is free software; you can redistribute it and/or
2752 modify it under the terms of the Perl Artistic License or the
2753 GNU General Public License as published by the Free Software
2754 Foundation; either version 2 of the License, or (at your option) any
2755 later version.
2756
2757 This program is distributed in the hope that it will be useful,
2758 but WITHOUT ANY WARRANTY; without even the implied warranty of
2759 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
2760 GNU General Public License for more details.
2761
2762 If you do not have a copy of the GNU General Public License write to
2763 the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
2764 MA 02139, USA.
2765
2766 =cut
2767