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