Commit | Line | Data |
24384a91 |
1 | # GetOpt::Long.pm -- Universal options parsing |
404cbe93 |
2 | |
24384a91 |
3 | package Getopt::Long; |
4 | |
5 | # RCS Status : $Id: GetoptLong.pm,v 2.9 1997-03-02 15:00:05+01 jv Exp $ |
404cbe93 |
6 | # Author : Johan Vromans |
7 | # Created On : Tue Sep 11 15:00:12 1990 |
8 | # Last Modified By: Johan Vromans |
24384a91 |
9 | # Last Modified On: Sun Mar 2 14:59:41 1997 |
10 | # Update Count : 586 |
404cbe93 |
11 | # Status : Released |
12 | |
f06db76b |
13 | =head1 NAME |
14 | |
404cbe93 |
15 | GetOptions - extended processing of command line options |
f06db76b |
16 | |
17 | =head1 SYNOPSIS |
18 | |
404cbe93 |
19 | use Getopt::Long; |
20 | $result = GetOptions (...option-descriptions...); |
f06db76b |
21 | |
22 | =head1 DESCRIPTION |
23 | |
24 | The Getopt::Long module implements an extended getopt function called |
404cbe93 |
25 | GetOptions(). This function adheres to the POSIX syntax for command |
26 | line options, with GNU extensions. In general, this means that options |
27 | have long names instead of single letters, and are introduced with a |
88e49c4e |
28 | double dash "--". Support for bundling of command line options, as was |
29 | the case with the more traditional single-letter approach, is provided |
30 | but not enabled by default. For example, the UNIX "ps" command can be |
31 | given the command line "option" |
f06db76b |
32 | |
404cbe93 |
33 | -vax |
f06db76b |
34 | |
404cbe93 |
35 | which means the combination of B<-v>, B<-a> and B<-x>. With the new |
36 | syntax B<--vax> would be a single option, probably indicating a |
37 | computer architecture. |
f06db76b |
38 | |
404cbe93 |
39 | Command line options can be used to set values. These values can be |
40 | specified in one of two ways: |
f06db76b |
41 | |
404cbe93 |
42 | --size 24 |
43 | --size=24 |
f06db76b |
44 | |
404cbe93 |
45 | GetOptions is called with a list of option-descriptions, each of which |
46 | consists of two elements: the option specifier and the option linkage. |
47 | The option specifier defines the name of the option and, optionally, |
48 | the value it can take. The option linkage is usually a reference to a |
49 | variable that will be set when the option is used. For example, the |
50 | following call to GetOptions: |
f06db76b |
51 | |
404cbe93 |
52 | &GetOptions("size=i" => \$offset); |
53 | |
54 | will accept a command line option "size" that must have an integer |
55 | value. With a command line of "--size 24" this will cause the variable |
56 | $offset to get the value 24. |
57 | |
58 | Alternatively, the first argument to GetOptions may be a reference to |
59 | a HASH describing the linkage for the options. The following call is |
60 | equivalent to the example above: |
61 | |
62 | %optctl = ("size" => \$offset); |
63 | &GetOptions(\%optctl, "size=i"); |
64 | |
65 | Linkage may be specified using either of the above methods, or both. |
66 | Linkage specified in the argument list takes precedence over the |
67 | linkage specified in the HASH. |
68 | |
69 | The command line options are taken from array @ARGV. Upon completion |
70 | of GetOptions, @ARGV will contain the rest (i.e. the non-options) of |
71 | the command line. |
16c18a90 |
72 | |
404cbe93 |
73 | Each option specifier designates the name of the option, optionally |
74 | followed by an argument specifier. Values for argument specifiers are: |
75 | |
76 | =over 8 |
77 | |
5f05dabc |
78 | =item E<lt>noneE<gt> |
404cbe93 |
79 | |
80 | Option does not take an argument. |
81 | The option variable will be set to 1. |
82 | |
83 | =item ! |
84 | |
85 | Option does not take an argument and may be negated, i.e. prefixed by |
86 | "no". E.g. "foo!" will allow B<--foo> (with value 1) and B<-nofoo> |
87 | (with value 0). |
88 | The option variable will be set to 1, or 0 if negated. |
89 | |
90 | =item =s |
91 | |
92 | Option takes a mandatory string argument. |
93 | This string will be assigned to the option variable. |
94 | Note that even if the string argument starts with B<-> or B<-->, it |
95 | will not be considered an option on itself. |
96 | |
97 | =item :s |
98 | |
99 | Option takes an optional string argument. |
100 | This string will be assigned to the option variable. |
101 | If omitted, it will be assigned "" (an empty string). |
102 | If the string argument starts with B<-> or B<-->, it |
103 | will be considered an option on itself. |
104 | |
105 | =item =i |
106 | |
107 | Option takes a mandatory integer argument. |
108 | This value will be assigned to the option variable. |
109 | Note that the value may start with B<-> to indicate a negative |
110 | value. |
111 | |
112 | =item :i |
113 | |
114 | Option takes an optional integer argument. |
115 | This value will be assigned to the option variable. |
116 | If omitted, the value 0 will be assigned. |
117 | Note that the value may start with B<-> to indicate a negative |
118 | value. |
119 | |
120 | =item =f |
121 | |
122 | Option takes a mandatory real number argument. |
123 | This value will be assigned to the option variable. |
124 | Note that the value may start with B<-> to indicate a negative |
125 | value. |
126 | |
127 | =item :f |
128 | |
129 | Option takes an optional real number argument. |
130 | This value will be assigned to the option variable. |
131 | If omitted, the value 0 will be assigned. |
132 | |
133 | =back |
134 | |
135 | A lone dash B<-> is considered an option, the corresponding option |
136 | name is the empty string. |
137 | |
138 | A double dash on itself B<--> signals end of the options list. |
139 | |
140 | =head2 Linkage specification |
141 | |
142 | The linkage specifier is optional. If no linkage is explicitly |
143 | specified but a ref HASH is passed, GetOptions will place the value in |
144 | the HASH. For example: |
145 | |
146 | %optctl = (); |
147 | &GetOptions (\%optctl, "size=i"); |
148 | |
149 | will perform the equivalent of the assignment |
150 | |
151 | $optctl{"size"} = 24; |
152 | |
153 | For array options, a reference to an array is used, e.g.: |
154 | |
155 | %optctl = (); |
156 | &GetOptions (\%optctl, "sizes=i@"); |
157 | |
158 | with command line "-sizes 24 -sizes 48" will perform the equivalent of |
159 | the assignment |
160 | |
161 | $optctl{"sizes"} = [24, 48]; |
162 | |
381319f7 |
163 | For hash options (an option whose argument looks like "name=value"), |
164 | a reference to a hash is used, e.g.: |
165 | |
166 | %optctl = (); |
167 | &GetOptions (\%optctl, "define=s%"); |
168 | |
169 | with command line "--define foo=hello --define bar=world" will perform the |
170 | equivalent of the assignment |
171 | |
172 | $optctl{"define"} = {foo=>'hello', bar=>'world') |
173 | |
404cbe93 |
174 | If no linkage is explicitly specified and no ref HASH is passed, |
175 | GetOptions will put the value in a global variable named after the |
176 | option, prefixed by "opt_". To yield a usable Perl variable, |
177 | characters that are not part of the syntax for variables are |
178 | translated to underscores. For example, "--fpp-struct-return" will set |
179 | the variable $opt_fpp_struct_return. Note that this variable resides |
180 | in the namespace of the calling program, not necessarily B<main>. |
181 | For example: |
182 | |
183 | &GetOptions ("size=i", "sizes=i@"); |
184 | |
185 | with command line "-size 10 -sizes 24 -sizes 48" will perform the |
186 | equivalent of the assignments |
187 | |
188 | $opt_size = 10; |
189 | @opt_sizes = (24, 48); |
190 | |
191 | A lone dash B<-> is considered an option, the corresponding Perl |
192 | identifier is $opt_ . |
193 | |
194 | The linkage specifier can be a reference to a scalar, a reference to |
381319f7 |
195 | an array, a reference to a hash or a reference to a subroutine. |
404cbe93 |
196 | |
197 | If a REF SCALAR is supplied, the new value is stored in the referenced |
198 | variable. If the option occurs more than once, the previous value is |
199 | overwritten. |
200 | |
201 | If a REF ARRAY is supplied, the new value is appended (pushed) to the |
202 | referenced array. |
203 | |
381319f7 |
204 | If a REF HASH is supplied, the option value should look like "key" or |
205 | "key=value" (if the "=value" is omitted then a value of 1 is implied). |
206 | In this case, the element of the referenced hash with the key "key" |
207 | is assigned "value". |
208 | |
404cbe93 |
209 | If a REF CODE is supplied, the referenced subroutine is called with |
210 | two arguments: the option name and the option value. |
211 | The option name is always the true name, not an abbreviation or alias. |
f06db76b |
212 | |
404cbe93 |
213 | =head2 Aliases and abbreviations |
f06db76b |
214 | |
215 | The option name may actually be a list of option names, separated by |
404cbe93 |
216 | "|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name |
5f05dabc |
217 | of this option. If no linkage is specified, options "foo", "bar" and |
404cbe93 |
218 | "blech" all will set $opt_foo. |
f06db76b |
219 | |
220 | Option names may be abbreviated to uniqueness, depending on |
24384a91 |
221 | configuration option B<auto_abbrev>. |
f06db76b |
222 | |
404cbe93 |
223 | =head2 Non-option call-back routine |
f06db76b |
224 | |
5f05dabc |
225 | A special option specifier, E<lt>E<gt>, can be used to designate a subroutine |
404cbe93 |
226 | to handle non-option arguments. GetOptions will immediately call this |
227 | subroutine for every non-option it encounters in the options list. |
228 | This subroutine gets the name of the non-option passed. |
24384a91 |
229 | This feature requires configuration option B<permute>, see section |
230 | CONFIGURATION OPTIONS. |
231 | |
404cbe93 |
232 | See also the examples. |
f06db76b |
233 | |
404cbe93 |
234 | =head2 Option starters |
f06db76b |
235 | |
404cbe93 |
236 | On the command line, options can start with B<-> (traditional), B<--> |
237 | (POSIX) and B<+> (GNU, now being phased out). The latter is not |
238 | allowed if the environment variable B<POSIXLY_CORRECT> has been |
239 | defined. |
f06db76b |
240 | |
241 | Options that start with "--" may have an argument appended, separated |
242 | with an "=", e.g. "--foo=bar". |
243 | |
404cbe93 |
244 | =head2 Return value |
f06db76b |
245 | |
246 | A return status of 0 (false) indicates that the function detected |
247 | one or more errors. |
248 | |
404cbe93 |
249 | =head1 COMPATIBILITY |
250 | |
251 | Getopt::Long::GetOptions() is the successor of |
252 | B<newgetopt.pl> that came with Perl 4. It is fully upward compatible. |
253 | In fact, the Perl 5 version of newgetopt.pl is just a wrapper around |
254 | the module. |
255 | |
256 | If an "@" sign is appended to the argument specifier, the option is |
381319f7 |
257 | treated as an array. Value(s) are not set, but pushed into array |
258 | @opt_name. If explicit linkage is supplied, this must be a reference |
259 | to an ARRAY. |
260 | |
261 | If an "%" sign is appended to the argument specifier, the option is |
262 | treated as a hash. Value(s) of the form "name=value" are set by |
263 | setting the element of the hash %opt_name with key "name" to "value" |
264 | (if the "=value" portion is omitted it defaults to 1). If explicit |
265 | linkage is supplied, this must be a reference to a HASH. |
404cbe93 |
266 | |
24384a91 |
267 | If configuration option B<getopt_compat> is set (see section |
268 | CONFIGURATION OPTIONS), options that start with "+" or "-" may also |
269 | include their arguments, e.g. "+foo=bar". This is for compatiblity |
270 | with older implementations of the GNU "getopt" routine. |
404cbe93 |
271 | |
272 | If the first argument to GetOptions is a string consisting of only |
273 | non-alphanumeric characters, it is taken to specify the option starter |
274 | characters. Everything starting with one of these characters from the |
275 | starter will be considered an option. B<Using a starter argument is |
276 | strongly deprecated.> |
277 | |
278 | For convenience, option specifiers may have a leading B<-> or B<-->, |
279 | so it is possible to write: |
280 | |
281 | GetOptions qw(-foo=s --bar=i --ar=s); |
282 | |
f06db76b |
283 | =head1 EXAMPLES |
284 | |
404cbe93 |
285 | If the option specifier is "one:i" (i.e. takes an optional integer |
286 | argument), then the following situations are handled: |
f06db76b |
287 | |
288 | -one -two -> $opt_one = '', -two is next option |
289 | -one -2 -> $opt_one = -2 |
290 | |
404cbe93 |
291 | Also, assume specifiers "foo=s" and "bar:s" : |
f06db76b |
292 | |
293 | -bar -xxx -> $opt_bar = '', '-xxx' is next option |
294 | -foo -bar -> $opt_foo = '-bar' |
295 | -foo -- -> $opt_foo = '--' |
296 | |
297 | In GNU or POSIX format, option names and values can be combined: |
298 | |
299 | +foo=blech -> $opt_foo = 'blech' |
300 | --bar= -> $opt_bar = '' |
301 | --bar=-- -> $opt_bar = '--' |
302 | |
1fef88e7 |
303 | Example of using variable references: |
404cbe93 |
304 | |
305 | $ret = &GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar); |
306 | |
307 | With command line options "-foo blech -bar 24 -ar xx -ar yy" |
308 | this will result in: |
309 | |
5f05dabc |
310 | $foo = 'blech' |
404cbe93 |
311 | $opt_bar = 24 |
312 | @ar = ('xx','yy') |
313 | |
5f05dabc |
314 | Example of using the E<lt>E<gt> option specifier: |
404cbe93 |
315 | |
316 | @ARGV = qw(-foo 1 bar -foo 2 blech); |
317 | &GetOptions("foo=i", \$myfoo, "<>", \&mysub); |
318 | |
319 | Results: |
320 | |
321 | &mysub("bar") will be called (with $myfoo being 1) |
322 | &mysub("blech") will be called (with $myfoo being 2) |
323 | |
324 | Compare this with: |
325 | |
326 | @ARGV = qw(-foo 1 bar -foo 2 blech); |
327 | &GetOptions("foo=i", \$myfoo); |
328 | |
329 | This will leave the non-options in @ARGV: |
330 | |
331 | $myfoo -> 2 |
332 | @ARGV -> qw(bar blech) |
333 | |
24384a91 |
334 | =head1 CONFIGURATION OPTIONS |
335 | |
336 | B<GetOptions> can be configured by calling subroutine |
337 | B<Getopt::Long::config>. This subroutine takes a list of quoted |
338 | strings, each specifying a configuration option to be set, e.g. |
339 | B<ignore_case>. Options can be reset by prefixing with B<no_>, e.g. |
340 | B<no_ignore_case>. Case does not matter. Multiple calls to B<config> |
341 | are possible. |
404cbe93 |
342 | |
24384a91 |
343 | Previous versions of Getopt::Long used variables for the purpose of |
344 | configuring. Although manipulating these variables still work, it |
345 | is strongly encouraged to use the new B<config> routine. Besides, it |
346 | is much easier. |
347 | |
348 | The following options are available: |
404cbe93 |
349 | |
f06db76b |
350 | =over 12 |
351 | |
24384a91 |
352 | =item default |
353 | |
354 | This option causes all configuration options to be reset to their |
355 | default values. |
356 | |
357 | =item auto_abbrev |
f06db76b |
358 | |
359 | Allow option names to be abbreviated to uniqueness. |
24384a91 |
360 | Default is set unless environment variable |
361 | POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset. |
f06db76b |
362 | |
24384a91 |
363 | =item getopt_compat |
f06db76b |
364 | |
365 | Allow '+' to start options. |
24384a91 |
366 | Default is set unless environment variable |
367 | POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset. |
368 | |
369 | =item require_order |
370 | |
371 | Whether non-options are allowed to be mixed with |
372 | options. |
373 | Default is set unless environment variable |
374 | POSIXLY_CORRECT has been set, in which case b<require_order> is reset. |
f06db76b |
375 | |
24384a91 |
376 | See also B<permute>, which is the opposite of B<require_order>. |
377 | |
378 | =item permute |
f06db76b |
379 | |
380 | Whether non-options are allowed to be mixed with |
381 | options. |
24384a91 |
382 | Default is set unless environment variable |
383 | POSIXLY_CORRECT has been set, in which case B<permute> is reset. |
384 | Note that B<permute> is the opposite of B<require_order>. |
f06db76b |
385 | |
24384a91 |
386 | If B<permute> is set, this means that |
404cbe93 |
387 | |
388 | -foo arg1 -bar arg2 arg3 |
389 | |
390 | is equivalent to |
391 | |
392 | -foo -bar arg1 arg2 arg3 |
393 | |
394 | If a non-option call-back routine is specified, @ARGV will always be |
395 | empty upon succesful return of GetOptions since all options have been |
396 | processed, except when B<--> is used: |
397 | |
398 | -foo arg1 -bar arg2 -- arg3 |
399 | |
400 | will call the call-back routine for arg1 and arg2, and terminate |
401 | leaving arg2 in @ARGV. |
402 | |
24384a91 |
403 | If B<require_order> is set, options processing |
404cbe93 |
404 | terminates when the first non-option is encountered. |
405 | |
406 | -foo arg1 -bar arg2 arg3 |
407 | |
408 | is equivalent to |
409 | |
410 | -foo -- arg1 -bar arg2 arg3 |
411 | |
24384a91 |
412 | =item bundling (default: reset) |
f06db76b |
413 | |
88e49c4e |
414 | Setting this variable to a non-zero value will allow single-character |
415 | options to be bundled. To distinguish bundles from long option names, |
416 | long options must be introduced with B<--> and single-character |
417 | options (and bundles) with B<->. For example, |
418 | |
419 | ps -vax --vax |
420 | |
421 | would be equivalent to |
422 | |
423 | ps -v -a -x --vax |
424 | |
425 | provided "vax", "v", "a" and "x" have been defined to be valid |
426 | options. |
427 | |
428 | Bundled options can also include a value in the bundle; this value has |
429 | to be the last part of the bundle, e.g. |
430 | |
431 | scale -h24 -w80 |
432 | |
433 | is equivalent to |
434 | |
435 | scale -h 24 -w 80 |
436 | |
24384a91 |
437 | Note: resetting B<bundling> also resets B<bundling_override>. |
438 | |
439 | =item bundling_override (default: reset) |
440 | |
441 | If B<bundling_override> is set, bundling is enabled as with |
442 | B<bundling> but now long option names override option bundles. In the |
443 | above example, B<-vax> would be interpreted as the option "vax", not |
444 | the bundle "v", "a", "x". |
445 | |
446 | Note: resetting B<bundling_override> also resets B<bundling>. |
447 | |
88e49c4e |
448 | B<Note:> Using option bundling can easily lead to unexpected results, |
449 | especially when mixing long options and bundles. Caveat emptor. |
450 | |
24384a91 |
451 | =item ignore_case (default: set) |
452 | |
453 | If set, case is ignored when matching options. |
454 | |
455 | Note: resetting B<ignore_case> also resets B<ignore_case_always>. |
456 | |
457 | =item ignore_case_always (default: reset) |
458 | |
459 | When bundling is in effect, case is ignored on single-character |
460 | options also. |
88e49c4e |
461 | |
24384a91 |
462 | Note: resetting B<ignore_case_always> also resets B<ignore_case>. |
f06db76b |
463 | |
24384a91 |
464 | =item pass_through (default: reset) |
381319f7 |
465 | |
466 | Unknown options are passed through in @ARGV instead of being flagged |
467 | as errors. This makes it possible to write wrapper scripts that |
468 | process only part of the user supplied options, and passes the |
469 | remaining options to some other program. |
470 | |
24384a91 |
471 | This can be very confusing, especially when B<permute> is also set. |
472 | |
473 | =item debug (default: reset) |
474 | |
475 | Enable copious debugging output. |
476 | |
477 | =back |
478 | |
479 | =head1 OTHER USEFUL VARIABLES |
480 | |
481 | =over 12 |
381319f7 |
482 | |
404cbe93 |
483 | =item $Getopt::Long::VERSION |
f06db76b |
484 | |
404cbe93 |
485 | The version number of this Getopt::Long implementation in the format |
486 | C<major>.C<minor>. This can be used to have Exporter check the |
487 | version, e.g. |
f06db76b |
488 | |
24384a91 |
489 | use Getopt::Long 3.00; |
f06db76b |
490 | |
404cbe93 |
491 | You can inspect $Getopt::Long::major_version and |
492 | $Getopt::Long::minor_version for the individual components. |
a0d0e21e |
493 | |
404cbe93 |
494 | =item $Getopt::Long::error |
a0d0e21e |
495 | |
404cbe93 |
496 | Internal error flag. May be incremented from a call-back routine to |
497 | cause options parsing to fail. |
498 | |
404cbe93 |
499 | =back |
500 | |
501 | =cut |
a0d0e21e |
502 | |
24384a91 |
503 | ################ Copyright ################ |
504 | |
505 | # This program is Copyright 1990,1997 by Johan Vromans. |
a0d0e21e |
506 | # This program is free software; you can redistribute it and/or |
507 | # modify it under the terms of the GNU General Public License |
508 | # as published by the Free Software Foundation; either version 2 |
509 | # of the License, or (at your option) any later version. |
510 | # |
511 | # This program is distributed in the hope that it will be useful, |
512 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
513 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
514 | # GNU General Public License for more details. |
515 | # |
516 | # If you do not have a copy of the GNU General Public License write to |
517 | # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, |
518 | # MA 02139, USA. |
519 | |
24384a91 |
520 | ################ Module Preamble ################ |
a0d0e21e |
521 | |
24384a91 |
522 | use strict; |
a0d0e21e |
523 | |
24384a91 |
524 | BEGIN { |
525 | require 5.00327; |
526 | use Exporter (); |
527 | use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); |
528 | $VERSION = sprintf("%d.%02d", q$Revision: 2.9 $ =~ /(\d+)\.(\d+)/); |
a0d0e21e |
529 | |
24384a91 |
530 | @ISA = qw(Exporter); |
531 | @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); |
532 | %EXPORT_TAGS = (); |
533 | @EXPORT_OK = qw(); |
a0d0e21e |
534 | } |
535 | |
24384a91 |
536 | use vars @EXPORT, @EXPORT_OK; |
537 | # User visible variables. |
538 | use vars qw(&config $error $debug $major_version $minor_version); |
539 | # Deprecated visible variables. |
540 | use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order |
541 | $passthrough); |
542 | |
543 | ################ Local Variables ################ |
404cbe93 |
544 | |
24384a91 |
545 | my $gen_prefix; # generic prefix (option starters) |
546 | my $argend; # option list terminator |
547 | my %opctl; # table of arg.specs (long and abbrevs) |
548 | my %bopctl; # table of arg.specs (bundles) |
549 | my @opctl; # the possible long option names |
550 | my $pkg; # current context. Needed if no linkage. |
551 | my %aliases; # alias table |
552 | my $genprefix; # so we can call the same module more |
553 | my $opt; # current option |
554 | my $arg; # current option value, if any |
555 | my $array; # current option is array typed |
556 | my $hash; # current option is hash typed |
557 | my $key; # hash key for a hash option |
558 | # than once in differing environments |
559 | my $config_defaults; # set config defaults |
560 | my $find_option; # helper routine |
381319f7 |
561 | |
a0d0e21e |
562 | ################ Subroutines ################ |
563 | |
564 | sub GetOptions { |
565 | |
404cbe93 |
566 | my @optionlist = @_; # local copy of the option descriptions |
24384a91 |
567 | $argend = '--'; # option list terminator |
568 | %opctl = (); # table of arg.specs (long and abbrevs) |
569 | %bopctl = (); # table of arg.specs (bundles) |
570 | $pkg = (caller)[0]; # current context |
404cbe93 |
571 | # Needed if linkage is omitted. |
24384a91 |
572 | %aliases= (); # alias table |
404cbe93 |
573 | my @ret = (); # accum for non-options |
574 | my %linkage; # linkage |
575 | my $userlinkage; # user supplied HASH |
24384a91 |
576 | $genprefix = $gen_prefix; # so we can call the same module many times |
88e49c4e |
577 | $error = 0; |
404cbe93 |
578 | |
24384a91 |
579 | print STDERR ('GetOptions $Revision: 2.9 $ ', |
88e49c4e |
580 | "[GetOpt::Long $Getopt::Long::VERSION] -- ", |
404cbe93 |
581 | "called from package \"$pkg\".\n", |
381319f7 |
582 | " (@ARGV)\n", |
88e49c4e |
583 | " autoabbrev=$autoabbrev". |
584 | ",bundling=$bundling", |
585 | ",getopt_compat=$getopt_compat", |
88e49c4e |
586 | ",order=$order", |
381319f7 |
587 | ",\n ignorecase=$ignorecase", |
588 | ",passthrough=$passthrough", |
589 | ",genprefix=\"$genprefix\"", |
404cbe93 |
590 | ".\n") |
591 | if $debug; |
592 | |
593 | # Check for ref HASH as first argument. |
594 | $userlinkage = undef; |
595 | if ( ref($optionlist[0]) && ref($optionlist[0]) eq 'HASH' ) { |
596 | $userlinkage = shift (@optionlist); |
597 | } |
a0d0e21e |
598 | |
599 | # See if the first element of the optionlist contains option |
600 | # starter characters. |
601 | if ( $optionlist[0] =~ /^\W+$/ ) { |
602 | $genprefix = shift (@optionlist); |
603 | # Turn into regexp. |
604 | $genprefix =~ s/(\W)/\\$1/g; |
605 | $genprefix = "[" . $genprefix . "]"; |
606 | } |
607 | |
608 | # Verify correctness of optionlist. |
609 | %opctl = (); |
88e49c4e |
610 | %bopctl = (); |
404cbe93 |
611 | while ( @optionlist > 0 ) { |
612 | my $opt = shift (@optionlist); |
613 | |
381319f7 |
614 | # Strip leading prefix so people can specify "--foo=i" if they like. |
24384a91 |
615 | $opt = $' if $opt =~ /^($genprefix)+/; |
404cbe93 |
616 | |
617 | if ( $opt eq '<>' ) { |
618 | if ( (defined $userlinkage) |
619 | && !(@optionlist > 0 && ref($optionlist[0])) |
620 | && (exists $userlinkage->{$opt}) |
621 | && ref($userlinkage->{$opt}) ) { |
622 | unshift (@optionlist, $userlinkage->{$opt}); |
623 | } |
624 | unless ( @optionlist > 0 |
625 | && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) { |
626 | warn ("Option spec <> requires a reference to a subroutine\n"); |
88e49c4e |
627 | $error++; |
404cbe93 |
628 | next; |
629 | } |
630 | $linkage{'<>'} = shift (@optionlist); |
631 | next; |
632 | } |
633 | |
381319f7 |
634 | if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse][@%]?)?$/ ) { |
404cbe93 |
635 | warn ("Error in option spec: \"", $opt, "\"\n"); |
88e49c4e |
636 | $error++; |
a0d0e21e |
637 | next; |
638 | } |
404cbe93 |
639 | my ($o, $c, $a) = ($1, $2); |
88e49c4e |
640 | $c = '' unless defined $c; |
a0d0e21e |
641 | |
642 | if ( ! defined $o ) { |
404cbe93 |
643 | # empty -> '-' option |
88e49c4e |
644 | $opctl{$o = ''} = $c; |
a0d0e21e |
645 | } |
646 | else { |
647 | # Handle alias names |
404cbe93 |
648 | my @o = split (/\|/, $o); |
381319f7 |
649 | my $linko = $o = $o[0]; |
650 | # Force an alias if the option name is not locase. |
651 | $a = $o unless $o eq lc($o); |
88e49c4e |
652 | $o = lc ($o) |
653 | if $ignorecase > 1 |
654 | || ($ignorecase |
655 | && ($bundling ? length($o) > 1 : 1)); |
656 | |
404cbe93 |
657 | foreach ( @o ) { |
88e49c4e |
658 | if ( $bundling && length($_) == 1 ) { |
659 | $_ = lc ($_) if $ignorecase > 1; |
660 | if ( $c eq '!' ) { |
661 | $opctl{"no$_"} = $c; |
662 | warn ("Ignoring '!' modifier for short option $_\n"); |
663 | $c = ''; |
664 | } |
665 | $bopctl{$_} = $c; |
666 | } |
667 | else { |
668 | $_ = lc ($_) if $ignorecase; |
669 | if ( $c eq '!' ) { |
670 | $opctl{"no$_"} = $c; |
671 | $c = ''; |
672 | } |
673 | $opctl{$_} = $c; |
a0d0e21e |
674 | } |
a0d0e21e |
675 | if ( defined $a ) { |
676 | # Note alias. |
677 | $aliases{$_} = $a; |
678 | } |
679 | else { |
680 | # Set primary name. |
681 | $a = $_; |
682 | } |
683 | } |
381319f7 |
684 | $o = $linko; |
a0d0e21e |
685 | } |
404cbe93 |
686 | |
687 | # If no linkage is supplied in the @optionlist, copy it from |
688 | # the userlinkage if available. |
689 | if ( defined $userlinkage ) { |
690 | unless ( @optionlist > 0 && ref($optionlist[0]) ) { |
691 | if ( exists $userlinkage->{$o} && ref($userlinkage->{$o}) ) { |
692 | print STDERR ("=> found userlinkage for \"$o\": ", |
693 | "$userlinkage->{$o}\n") |
694 | if $debug; |
695 | unshift (@optionlist, $userlinkage->{$o}); |
696 | } |
697 | else { |
698 | # Do nothing. Being undefined will be handled later. |
699 | next; |
700 | } |
701 | } |
702 | } |
703 | |
704 | # Copy the linkage. If omitted, link to global variable. |
705 | if ( @optionlist > 0 && ref($optionlist[0]) ) { |
706 | print STDERR ("=> link \"$o\" to $optionlist[0]\n") |
707 | if $debug; |
381319f7 |
708 | if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) { |
404cbe93 |
709 | $linkage{$o} = shift (@optionlist); |
710 | } |
381319f7 |
711 | elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) { |
712 | $linkage{$o} = shift (@optionlist); |
713 | $opctl{$o} .= '@' unless $opctl{$o} =~ /\@$/; |
714 | } |
715 | elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) { |
716 | $linkage{$o} = shift (@optionlist); |
717 | $opctl{$o} .= '%' unless $opctl{$o} =~ /\%$/; |
718 | } |
404cbe93 |
719 | else { |
720 | warn ("Invalid option linkage for \"", $opt, "\"\n"); |
88e49c4e |
721 | $error++; |
404cbe93 |
722 | } |
723 | } |
724 | else { |
725 | # Link to global $opt_XXX variable. |
726 | # Make sure a valid perl identifier results. |
727 | my $ov = $o; |
728 | $ov =~ s/\W/_/g; |
381319f7 |
729 | if ( $c =~ /@/ ) { |
404cbe93 |
730 | print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n") |
731 | if $debug; |
732 | eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;"); |
733 | } |
381319f7 |
734 | elsif ( $c =~ /%/ ) { |
735 | print STDERR ("=> link \"$o\" to \%$pkg","::opt_$ov\n") |
736 | if $debug; |
737 | eval ("\$linkage{\$o} = \\\%".$pkg."::opt_$ov;"); |
738 | } |
404cbe93 |
739 | else { |
740 | print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n") |
741 | if $debug; |
742 | eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;"); |
743 | } |
744 | } |
a0d0e21e |
745 | } |
a0d0e21e |
746 | |
404cbe93 |
747 | # Bail out if errors found. |
88e49c4e |
748 | return 0 if $error; |
404cbe93 |
749 | |
88e49c4e |
750 | # Sort the possible long option names. |
24384a91 |
751 | @opctl = sort(keys (%opctl)) if $autoabbrev; |
a0d0e21e |
752 | |
88e49c4e |
753 | # Show the options tables if debugging. |
a0d0e21e |
754 | if ( $debug ) { |
404cbe93 |
755 | my ($arrow, $k, $v); |
a0d0e21e |
756 | $arrow = "=> "; |
757 | while ( ($k,$v) = each(%opctl) ) { |
758 | print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n"); |
759 | $arrow = " "; |
760 | } |
88e49c4e |
761 | $arrow = "=> "; |
762 | while ( ($k,$v) = each(%bopctl) ) { |
763 | print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n"); |
764 | $arrow = " "; |
765 | } |
a0d0e21e |
766 | } |
767 | |
404cbe93 |
768 | # Process argument list |
769 | while ( @ARGV > 0 ) { |
a0d0e21e |
770 | |
a0d0e21e |
771 | #### Get next argument #### |
772 | |
773 | $opt = shift (@ARGV); |
a0d0e21e |
774 | $arg = undef; |
381319f7 |
775 | $array = $hash = 0; |
404cbe93 |
776 | print STDERR ("=> option \"", $opt, "\"\n") if $debug; |
a0d0e21e |
777 | |
778 | #### Determine what we have #### |
779 | |
780 | # Double dash is option list terminator. |
781 | if ( $opt eq $argend ) { |
404cbe93 |
782 | # Finish. Push back accumulated arguments and return. |
783 | unshift (@ARGV, @ret) |
88e49c4e |
784 | if $order == $PERMUTE; |
785 | return ($error == 0); |
a0d0e21e |
786 | } |
404cbe93 |
787 | |
381319f7 |
788 | my $tryopt = $opt; |
789 | |
790 | # find_option operates on the GLOBAL $opt and $arg! |
24384a91 |
791 | if ( &$find_option () ) { |
381319f7 |
792 | |
793 | # find_option undefines $opt in case of errors. |
794 | next unless defined $opt; |
a0d0e21e |
795 | |
381319f7 |
796 | if ( defined $arg ) { |
797 | $opt = $aliases{$opt} if defined $aliases{$opt}; |
798 | |
799 | if ( defined $linkage{$opt} ) { |
800 | print STDERR ("=> ref(\$L{$opt}) -> ", |
801 | ref($linkage{$opt}), "\n") if $debug; |
802 | |
803 | if ( ref($linkage{$opt}) eq 'SCALAR' ) { |
804 | print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug; |
805 | ${$linkage{$opt}} = $arg; |
806 | } |
807 | elsif ( ref($linkage{$opt}) eq 'ARRAY' ) { |
808 | print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") |
809 | if $debug; |
810 | push (@{$linkage{$opt}}, $arg); |
811 | } |
812 | elsif ( ref($linkage{$opt}) eq 'HASH' ) { |
813 | print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n") |
814 | if $debug; |
815 | $linkage{$opt}->{$key} = $arg; |
816 | } |
817 | elsif ( ref($linkage{$opt}) eq 'CODE' ) { |
818 | print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n") |
819 | if $debug; |
820 | &{$linkage{$opt}}($opt, $arg); |
821 | } |
822 | else { |
823 | print STDERR ("Invalid REF type \"", ref($linkage{$opt}), |
824 | "\" in linkage\n"); |
825 | die ("Getopt::Long -- internal error!\n"); |
826 | } |
827 | } |
828 | # No entry in linkage means entry in userlinkage. |
829 | elsif ( $array ) { |
830 | if ( defined $userlinkage->{$opt} ) { |
831 | print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n") |
832 | if $debug; |
833 | push (@{$userlinkage->{$opt}}, $arg); |
834 | } |
835 | else { |
836 | print STDERR ("=>\$L{$opt} = [\"$arg\"]\n") |
837 | if $debug; |
838 | $userlinkage->{$opt} = [$arg]; |
839 | } |
840 | } |
841 | elsif ( $hash ) { |
842 | if ( defined $userlinkage->{$opt} ) { |
843 | print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n") |
844 | if $debug; |
845 | $userlinkage->{$opt}->{$key} = $arg; |
846 | } |
847 | else { |
848 | print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n") |
849 | if $debug; |
850 | $userlinkage->{$opt} = {$key => $arg}; |
851 | } |
852 | } |
853 | else { |
854 | print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug; |
855 | $userlinkage->{$opt} = $arg; |
856 | } |
857 | } |
a0d0e21e |
858 | } |
404cbe93 |
859 | |
860 | # Not an option. Save it if we $PERMUTE and don't have a <>. |
88e49c4e |
861 | elsif ( $order == $PERMUTE ) { |
404cbe93 |
862 | # Try non-options call-back. |
863 | my $cb; |
864 | if ( (defined ($cb = $linkage{'<>'})) ) { |
381319f7 |
865 | &$cb($tryopt); |
404cbe93 |
866 | } |
867 | else { |
381319f7 |
868 | print STDERR ("=> saving \"$tryopt\" ", |
88e49c4e |
869 | "(not an option, may permute)\n") if $debug; |
381319f7 |
870 | push (@ret, $tryopt); |
404cbe93 |
871 | } |
a0d0e21e |
872 | next; |
873 | } |
404cbe93 |
874 | |
a0d0e21e |
875 | # ...otherwise, terminate. |
876 | else { |
404cbe93 |
877 | # Push this one back and exit. |
381319f7 |
878 | unshift (@ARGV, $tryopt); |
88e49c4e |
879 | return ($error == 0); |
a0d0e21e |
880 | } |
881 | |
381319f7 |
882 | } |
883 | |
884 | # Finish. |
885 | if ( $order == $PERMUTE ) { |
886 | # Push back accumulated arguments |
887 | print STDERR ("=> restoring \"", join('" "', @ret), "\"\n") |
888 | if $debug && @ret > 0; |
889 | unshift (@ARGV, @ret) if @ret > 0; |
890 | } |
891 | |
892 | return ($error == 0); |
893 | } |
894 | |
24384a91 |
895 | sub config (@) { |
896 | my (@options) = @_; |
897 | my $opt; |
898 | foreach $opt ( @options ) { |
899 | my $try = lc ($opt); |
900 | my $action = 1; |
901 | if ( $try =~ /^no_?/ ) { |
902 | $action = 0; |
903 | $try = $'; |
904 | } |
905 | if ( $try eq 'default' or $try eq 'defaults' ) { |
906 | &$config_defaults () if $action; |
907 | } |
908 | elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) { |
909 | $autoabbrev = $action; |
910 | } |
911 | elsif ( $try eq 'getopt_compat' ) { |
912 | $getopt_compat = $action; |
913 | } |
914 | elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) { |
915 | $ignorecase = $action; |
916 | } |
917 | elsif ( $try eq 'ignore_case_always' ) { |
918 | $ignorecase = $action ? 2 : 0; |
919 | } |
920 | elsif ( $try eq 'bundling' ) { |
921 | $bundling = $action; |
922 | } |
923 | elsif ( $try eq 'bundling_override' ) { |
924 | $bundling = $action ? 2 : 0; |
925 | } |
926 | elsif ( $try eq 'require_order' ) { |
927 | $order = $action ? $REQUIRE_ORDER : $PERMUTE; |
928 | } |
929 | elsif ( $try eq 'permute' ) { |
930 | $order = $action ? $PERMUTE : $REQUIRE_ORDER; |
931 | } |
932 | elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) { |
933 | $passthrough = $action; |
934 | } |
935 | elsif ( $try eq 'debug' ) { |
936 | $debug = $action; |
937 | } |
938 | else { |
939 | $Carp::CarpLevel = 1; |
940 | Carp::croak("Getopt::Long: unknown config parameter \"$opt\"") |
941 | } |
942 | } |
943 | } |
944 | |
945 | # Modified from Exporter. This one handles 2.001 and 2.01 etc just like 2.1. |
946 | sub require_version { |
947 | no strict; |
948 | my ($self, $wanted) = @_; |
949 | my $pkg = ref $self || $self; |
950 | my $version = $ {"${pkg}::VERSION"} || "(undef)"; |
951 | |
952 | $wanted .= '.0' unless $wanted =~ /\./; |
953 | $wanted = $1 * 1000 + $2 if $wanted =~ /^(\d+)\.(\d+)$/; |
954 | $version = $1 * 1000 + $2 if $version =~ /^(\d+)\.(\d+)$/; |
955 | if ( $version < $wanted ) { |
956 | $version =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e; |
957 | $wanted =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e; |
958 | $Carp::CarpLevel = 1; |
959 | Carp::croak("$pkg $wanted required--this is only version $version") |
960 | } |
961 | $version; |
962 | } |
963 | |
964 | ################ Private Subroutines ################ |
965 | |
966 | $find_option = sub { |
381319f7 |
967 | |
24384a91 |
968 | return 0 unless $opt =~ /^$genprefix/; |
381319f7 |
969 | |
24384a91 |
970 | $opt = $'; |
971 | my ($starter) = $&; |
381319f7 |
972 | |
973 | my $optarg = undef; # value supplied with --opt=value |
974 | my $rest = undef; # remainder from unbundling |
975 | |
976 | # If it is a long option, it may include the value. |
977 | if (($starter eq "--" || $getopt_compat) |
24384a91 |
978 | && $opt =~ /^([^=]+)=/ ) { |
381319f7 |
979 | $opt = $1; |
24384a91 |
980 | $optarg = $'; |
381319f7 |
981 | print STDERR ("=> option \"", $opt, |
982 | "\", optarg = \"$optarg\"\n") if $debug; |
983 | } |
984 | |
985 | #### Look it up ### |
986 | |
987 | my $tryopt = $opt; # option to try |
988 | my $optbl = \%opctl; # table to look it up (long names) |
24384a91 |
989 | my $type; |
381319f7 |
990 | |
991 | if ( $bundling && $starter eq '-' ) { |
992 | # Unbundle single letter option. |
993 | $rest = substr ($tryopt, 1); |
994 | $tryopt = substr ($tryopt, 0, 1); |
995 | $tryopt = lc ($tryopt) if $ignorecase > 1; |
996 | print STDERR ("=> $starter$tryopt unbundled from ", |
997 | "$starter$tryopt$rest\n") if $debug; |
998 | $rest = undef unless $rest ne ''; |
999 | $optbl = \%bopctl; # look it up in the short names table |
24384a91 |
1000 | |
1001 | # If bundling == 2, long options can override bundles. |
1002 | if ( $bundling == 2 and |
1003 | defined ($type = $opctl{$tryopt.$rest}) ) { |
1004 | print STDERR ("=> $starter$tryopt rebundled to ", |
1005 | "$starter$tryopt$rest\n") if $debug; |
1006 | $tryopt .= $rest; |
1007 | undef $rest; |
1008 | } |
381319f7 |
1009 | } |
1010 | |
1011 | # Try auto-abbreviation. |
1012 | elsif ( $autoabbrev ) { |
1013 | # Downcase if allowed. |
1014 | $tryopt = $opt = lc ($opt) if $ignorecase; |
1015 | # Turn option name into pattern. |
1016 | my $pat = quotemeta ($opt); |
1017 | # Look up in option names. |
1018 | my @hits = grep (/^$pat/, @opctl); |
1019 | print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ", |
1020 | "out of ", scalar(@opctl), "\n") if $debug; |
1021 | |
1022 | # Check for ambiguous results. |
1023 | unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) { |
1024 | # See if all matches are for the same option. |
1025 | my %hit; |
1026 | foreach ( @hits ) { |
1027 | $_ = $aliases{$_} if defined $aliases{$_}; |
1028 | $hit{$_} = 1; |
1029 | } |
1030 | # Now see if it really is ambiguous. |
1031 | unless ( keys(%hit) == 1 ) { |
1032 | return 0 if $passthrough; |
a0d0e21e |
1033 | print STDERR ("Option ", $opt, " is ambiguous (", |
1034 | join(", ", @hits), ")\n"); |
88e49c4e |
1035 | $error++; |
381319f7 |
1036 | undef $opt; |
1037 | return 1; |
a0d0e21e |
1038 | } |
381319f7 |
1039 | @hits = keys(%hit); |
a0d0e21e |
1040 | } |
1041 | |
381319f7 |
1042 | # Complete the option name, if appropriate. |
1043 | if ( @hits == 1 && $hits[0] ne $opt ) { |
1044 | $tryopt = $hits[0]; |
1045 | $tryopt = lc ($tryopt) if $ignorecase; |
1046 | print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n") |
1047 | if $debug; |
a0d0e21e |
1048 | } |
381319f7 |
1049 | } |
a0d0e21e |
1050 | |
16c18a90 |
1051 | # Map to all lowercase if ignoring case. |
1052 | elsif ( $ignorecase ) { |
1053 | $tryopt = lc ($opt); |
1054 | } |
1055 | |
381319f7 |
1056 | # Check validity by fetching the info. |
24384a91 |
1057 | $type = $optbl->{$tryopt} unless defined $type; |
381319f7 |
1058 | unless ( defined $type ) { |
1059 | return 0 if $passthrough; |
1060 | warn ("Unknown option: ", $opt, "\n"); |
1061 | $error++; |
1062 | return 1; |
1063 | } |
1064 | # Apparently valid. |
1065 | $opt = $tryopt; |
1066 | print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug; |
a0d0e21e |
1067 | |
381319f7 |
1068 | #### Determine argument status #### |
a0d0e21e |
1069 | |
381319f7 |
1070 | # If it is an option w/o argument, we're almost finished with it. |
1071 | if ( $type eq '' || $type eq '!' ) { |
1072 | if ( defined $optarg ) { |
1073 | return 0 if $passthrough; |
1074 | print STDERR ("Option ", $opt, " does not take an argument\n"); |
1075 | $error++; |
1076 | undef $opt; |
1077 | } |
1078 | elsif ( $type eq '' ) { |
1079 | $arg = 1; # supply explicit value |
1080 | } |
1081 | else { |
1082 | substr ($opt, 0, 2) = ''; # strip NO prefix |
1083 | $arg = 0; # supply explicit value |
1084 | } |
1085 | unshift (@ARGV, $starter.$rest) if defined $rest; |
1086 | return 1; |
1087 | } |
a0d0e21e |
1088 | |
381319f7 |
1089 | # Get mandatory status and type info. |
1090 | my $mand; |
1091 | ($mand, $type, $array, $hash) = $type =~ /^(.)(.)(@?)(%?)$/; |
1092 | |
1093 | # Check if there is an option argument available. |
1094 | if ( defined $optarg ? ($optarg eq '') |
1095 | : !(defined $rest || @ARGV > 0) ) { |
1096 | # Complain if this option needs an argument. |
1097 | if ( $mand eq "=" ) { |
1098 | return 0 if $passthrough; |
1099 | print STDERR ("Option ", $opt, " requires an argument\n"); |
1100 | $error++; |
1101 | undef $opt; |
1102 | } |
1103 | if ( $mand eq ":" ) { |
1104 | $arg = $type eq "s" ? '' : 0; |
a0d0e21e |
1105 | } |
381319f7 |
1106 | return 1; |
1107 | } |
a0d0e21e |
1108 | |
381319f7 |
1109 | # Get (possibly optional) argument. |
1110 | $arg = (defined $rest ? $rest |
1111 | : (defined $optarg ? $optarg : shift (@ARGV))); |
a0d0e21e |
1112 | |
381319f7 |
1113 | # Get key if this is a "name=value" pair for a hash option. |
1114 | $key = undef; |
1115 | if ($hash && defined $arg) { |
24384a91 |
1116 | ($key, $arg) = ($arg =~ /=/o) ? ($`, $') : ($arg, 1); |
381319f7 |
1117 | } |
a0d0e21e |
1118 | |
381319f7 |
1119 | #### Check if the argument is valid for this option #### |
a0d0e21e |
1120 | |
381319f7 |
1121 | if ( $type eq "s" ) { # string |
1122 | # A mandatory string takes anything. |
1123 | return 1 if $mand eq "="; |
a0d0e21e |
1124 | |
381319f7 |
1125 | # An optional string takes almost anything. |
1126 | return 1 if defined $optarg || defined $rest; |
1127 | return 1 if $arg eq "-"; # ?? |
a0d0e21e |
1128 | |
381319f7 |
1129 | # Check for option or option list terminator. |
1130 | if ($arg eq $argend || |
1131 | $arg =~ /^$genprefix.+/) { |
1132 | # Push back. |
1133 | unshift (@ARGV, $arg); |
1134 | # Supply empty value. |
1135 | $arg = ''; |
a0d0e21e |
1136 | } |
381319f7 |
1137 | } |
a0d0e21e |
1138 | |
381319f7 |
1139 | elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer |
1140 | if ( $arg !~ /^-?[0-9]+$/ ) { |
1141 | if ( defined $optarg || $mand eq "=" ) { |
1142 | return 0 if $passthrough; |
1143 | print STDERR ("Value \"", $arg, "\" invalid for option ", |
1144 | $opt, " (number expected)\n"); |
1145 | $error++; |
1146 | undef $opt; |
1147 | # Push back. |
1148 | unshift (@ARGV, $starter.$rest) if defined $rest; |
1149 | } |
1150 | else { |
1151 | # Push back. |
1152 | unshift (@ARGV, defined $rest ? $starter.$rest : $arg); |
1153 | # Supply default value. |
1154 | $arg = 0; |
a0d0e21e |
1155 | } |
a0d0e21e |
1156 | } |
a0d0e21e |
1157 | } |
1158 | |
381319f7 |
1159 | elsif ( $type eq "f" ) { # real number, int is also ok |
1160 | if ( $arg !~ /^-?[0-9.]+([eE]-?[0-9]+)?$/ ) { |
1161 | if ( defined $optarg || $mand eq "=" ) { |
1162 | return 0 if $passthrough; |
1163 | print STDERR ("Value \"", $arg, "\" invalid for option ", |
1164 | $opt, " (real number expected)\n"); |
1165 | $error++; |
1166 | undef $opt; |
1167 | # Push back. |
1168 | unshift (@ARGV, $starter.$rest) if defined $rest; |
a0d0e21e |
1169 | } |
1170 | else { |
381319f7 |
1171 | # Push back. |
1172 | unshift (@ARGV, defined $rest ? $starter.$rest : $arg); |
1173 | # Supply default value. |
1174 | $arg = 0.0; |
a0d0e21e |
1175 | } |
1176 | } |
1177 | } |
381319f7 |
1178 | else { |
1179 | die ("GetOpt::Long internal error (Can't happen)\n"); |
a0d0e21e |
1180 | } |
381319f7 |
1181 | return 1; |
24384a91 |
1182 | }; |
1183 | |
1184 | $config_defaults = sub { |
1185 | # Handle POSIX compliancy. |
1186 | if ( defined $ENV{"POSIXLY_CORRECT"} ) { |
1187 | $gen_prefix = "(--|-)"; |
1188 | $autoabbrev = 0; # no automatic abbrev of options |
1189 | $bundling = 0; # no bundling of single letter switches |
1190 | $getopt_compat = 0; # disallow '+' to start options |
1191 | $order = $REQUIRE_ORDER; |
1192 | } |
1193 | else { |
1194 | $gen_prefix = "(--|-|\\+)"; |
1195 | $autoabbrev = 1; # automatic abbrev of options |
1196 | $bundling = 0; # bundling off by default |
1197 | $getopt_compat = 1; # allow '+' to start options |
1198 | $order = $PERMUTE; |
1199 | } |
1200 | # Other configurable settings. |
1201 | $debug = 0; # for debugging |
1202 | $error = 0; # error tally |
1203 | $ignorecase = 1; # ignore case when matching options |
1204 | $passthrough = 0; # leave unrecognized options alone |
1205 | }; |
1206 | |
1207 | ################ Initialization ################ |
1208 | |
1209 | # Values for $order. See GNU getopt.c for details. |
1210 | ($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2); |
1211 | # Version major/minor numbers. |
1212 | ($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/; |
1213 | |
1214 | # Set defaults. |
1215 | &$config_defaults (); |
a0d0e21e |
1216 | |
1217 | ################ Package return ################ |
1218 | |
88e49c4e |
1219 | 1; |