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