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