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