Context Navigation

Long.pm

Visit:

Last change on this file was 3181, checked in by bird, 19 years ago
perl 5.8.8
File size: 73.5 KB

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

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: trunk/essentials/dev-lang/perl/lib/Getopt/Long.pm

Download in other formats: