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