1 # GetOpt::Long.pm -- POSIX compatible options parsing
3 # RCS Status : $Id: GetoptLong.pm,v 2.3 1996-04-05 21:03:05+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: Fri Apr 5 21:02:52 1996
16 @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
17 $VERSION = sprintf("%d.%02d", '$Revision: 2.3 $ ' =~ /(\d+)\.(\d+)/);
18 use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
19 $error $debug $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER
20 $VERSION $major_version $minor_version);
25 GetOptions - extended processing of command line options
30 $result = GetOptions (...option-descriptions...);
34 The Getopt::Long module implements an extended getopt function called
35 GetOptions(). This function adheres to the POSIX syntax for command
36 line options, with GNU extensions. In general, this means that options
37 have long names instead of single letters, and are introduced with a
38 double dash "--". Support for bundling of command line options, as was
39 the case with the more traditional single-letter approach, is provided
40 but not enabled by default. For example, the UNIX "ps" command can be
41 given the command line "option"
45 which means the combination of B<-v>, B<-a> and B<-x>. With the new
46 syntax B<--vax> would be a single option, probably indicating a
47 computer architecture.
49 Command line options can be used to set values. These values can be
50 specified in one of two ways:
55 GetOptions is called with a list of option-descriptions, each of which
56 consists of two elements: the option specifier and the option linkage.
57 The option specifier defines the name of the option and, optionally,
58 the value it can take. The option linkage is usually a reference to a
59 variable that will be set when the option is used. For example, the
60 following call to GetOptions:
62 &GetOptions("size=i" => \$offset);
64 will accept a command line option "size" that must have an integer
65 value. With a command line of "--size 24" this will cause the variable
66 $offset to get the value 24.
68 Alternatively, the first argument to GetOptions may be a reference to
69 a HASH describing the linkage for the options. The following call is
70 equivalent to the example above:
72 %optctl = ("size" => \$offset);
73 &GetOptions(\%optctl, "size=i");
75 Linkage may be specified using either of the above methods, or both.
76 Linkage specified in the argument list takes precedence over the
77 linkage specified in the HASH.
79 The command line options are taken from array @ARGV. Upon completion
80 of GetOptions, @ARGV will contain the rest (i.e. the non-options) of
83 Each option specifier designates the name of the option, optionally
84 followed by an argument specifier. Values for argument specifiers are:
90 Option does not take an argument.
91 The option variable will be set to 1.
95 Option does not take an argument and may be negated, i.e. prefixed by
96 "no". E.g. "foo!" will allow B<--foo> (with value 1) and B<-nofoo>
98 The option variable will be set to 1, or 0 if negated.
102 Option takes a mandatory string argument.
103 This string will be assigned to the option variable.
104 Note that even if the string argument starts with B<-> or B<-->, it
105 will not be considered an option on itself.
109 Option takes an optional string argument.
110 This string will be assigned to the option variable.
111 If omitted, it will be assigned "" (an empty string).
112 If the string argument starts with B<-> or B<-->, it
113 will be considered an option on itself.
117 Option takes a mandatory integer argument.
118 This value will be assigned to the option variable.
119 Note that the value may start with B<-> to indicate a negative
124 Option takes an optional integer argument.
125 This value will be assigned to the option variable.
126 If omitted, the value 0 will be assigned.
127 Note that the value may start with B<-> to indicate a negative
132 Option takes a mandatory real number argument.
133 This value will be assigned to the option variable.
134 Note that the value may start with B<-> to indicate a negative
139 Option takes an optional real number argument.
140 This value will be assigned to the option variable.
141 If omitted, the value 0 will be assigned.
145 A lone dash B<-> is considered an option, the corresponding option
146 name is the empty string.
148 A double dash on itself B<--> signals end of the options list.
150 =head2 Linkage specification
152 The linkage specifier is optional. If no linkage is explicitly
153 specified but a ref HASH is passed, GetOptions will place the value in
154 the HASH. For example:
157 &GetOptions (\%optctl, "size=i");
159 will perform the equivalent of the assignment
161 $optctl{"size"} = 24;
163 For array options, a reference to an array is used, e.g.:
166 &GetOptions (\%optctl, "sizes=i@");
168 with command line "-sizes 24 -sizes 48" will perform the equivalent of
171 $optctl{"sizes"} = [24, 48];
173 If no linkage is explicitly specified and no ref HASH is passed,
174 GetOptions will put the value in a global variable named after the
175 option, prefixed by "opt_". To yield a usable Perl variable,
176 characters that are not part of the syntax for variables are
177 translated to underscores. For example, "--fpp-struct-return" will set
178 the variable $opt_fpp_struct_return. Note that this variable resides
179 in the namespace of the calling program, not necessarily B<main>.
182 &GetOptions ("size=i", "sizes=i@");
184 with command line "-size 10 -sizes 24 -sizes 48" will perform the
185 equivalent of the assignments
188 @opt_sizes = (24, 48);
190 A lone dash B<-> is considered an option, the corresponding Perl
191 identifier is $opt_ .
193 The linkage specifier can be a reference to a scalar, a reference to
194 an array or a reference to a subroutine.
196 If a REF SCALAR is supplied, the new value is stored in the referenced
197 variable. If the option occurs more than once, the previous value is
200 If a REF ARRAY is supplied, the new value is appended (pushed) to the
203 If a REF CODE is supplied, the referenced subroutine is called with
204 two arguments: the option name and the option value.
205 The option name is always the true name, not an abbreviation or alias.
207 =head2 Aliases and abbreviations
209 The option name may actually be a list of option names, separated by
210 "|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name
211 op this option. If no linkage is specified, options "foo", "bar" and
212 "blech" all will set $opt_foo.
214 Option names may be abbreviated to uniqueness, depending on
215 configuration variable $Getopt::Long::autoabbrev.
217 =head2 Non-option call-back routine
219 A special option specifier, <>, can be used to designate a subroutine
220 to handle non-option arguments. GetOptions will immediately call this
221 subroutine for every non-option it encounters in the options list.
222 This subroutine gets the name of the non-option passed.
223 This feature requires $Getopt::Long::order to have the value $PERMUTE.
224 See also the examples.
226 =head2 Option starters
228 On the command line, options can start with B<-> (traditional), B<-->
229 (POSIX) and B<+> (GNU, now being phased out). The latter is not
230 allowed if the environment variable B<POSIXLY_CORRECT> has been
233 Options that start with "--" may have an argument appended, separated
234 with an "=", e.g. "--foo=bar".
238 A return status of 0 (false) indicates that the function detected
243 Getopt::Long::GetOptions() is the successor of
244 B<newgetopt.pl> that came with Perl 4. It is fully upward compatible.
245 In fact, the Perl 5 version of newgetopt.pl is just a wrapper around
248 If an "@" sign is appended to the argument specifier, the option is
249 treated as an array. Value(s) are not set, but pushed into array
250 @opt_name. This only applies if no linkage is supplied.
252 If configuration variable $Getopt::Long::getopt_compat is set to a
253 non-zero value, options that start with "+" may also include their
254 arguments, e.g. "+foo=bar". This is for compatiblity with older
255 implementations of the GNU "getopt" routine.
257 If the first argument to GetOptions is a string consisting of only
258 non-alphanumeric characters, it is taken to specify the option starter
259 characters. Everything starting with one of these characters from the
260 starter will be considered an option. B<Using a starter argument is
261 strongly deprecated.>
263 For convenience, option specifiers may have a leading B<-> or B<-->,
264 so it is possible to write:
266 GetOptions qw(-foo=s --bar=i --ar=s);
270 If the option specifier is "one:i" (i.e. takes an optional integer
271 argument), then the following situations are handled:
273 -one -two -> $opt_one = '', -two is next option
274 -one -2 -> $opt_one = -2
276 Also, assume specifiers "foo=s" and "bar:s" :
278 -bar -xxx -> $opt_bar = '', '-xxx' is next option
279 -foo -bar -> $opt_foo = '-bar'
280 -foo -- -> $opt_foo = '--'
282 In GNU or POSIX format, option names and values can be combined:
284 +foo=blech -> $opt_foo = 'blech'
285 --bar= -> $opt_bar = ''
286 --bar=-- -> $opt_bar = '--'
288 Example of using variabel references:
290 $ret = &GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar);
292 With command line options "-foo blech -bar 24 -ar xx -ar yy"
299 Example of using the <> option specifier:
301 @ARGV = qw(-foo 1 bar -foo 2 blech);
302 &GetOptions("foo=i", \$myfoo, "<>", \&mysub);
306 &mysub("bar") will be called (with $myfoo being 1)
307 &mysub("blech") will be called (with $myfoo being 2)
311 @ARGV = qw(-foo 1 bar -foo 2 blech);
312 &GetOptions("foo=i", \$myfoo);
314 This will leave the non-options in @ARGV:
317 @ARGV -> qw(bar blech)
319 =head1 CONFIGURATION VARIABLES
321 The following variables can be set to change the default behaviour of
326 =item $Getopt::Long::autoabbrev
328 Allow option names to be abbreviated to uniqueness.
329 Default is 1 unless environment variable
330 POSIXLY_CORRECT has been set.
332 =item $Getopt::Long::getopt_compat
334 Allow '+' to start options.
335 Default is 1 unless environment variable
336 POSIXLY_CORRECT has been set.
338 =item $Getopt::Long::order
340 Whether non-options are allowed to be mixed with
342 Default is $REQUIRE_ORDER if environment variable
343 POSIXLY_CORRECT has been set, $PERMUTE otherwise.
347 -foo arg1 -bar arg2 arg3
351 -foo -bar arg1 arg2 arg3
353 If a non-option call-back routine is specified, @ARGV will always be
354 empty upon succesful return of GetOptions since all options have been
355 processed, except when B<--> is used:
357 -foo arg1 -bar arg2 -- arg3
359 will call the call-back routine for arg1 and arg2, and terminate
360 leaving arg2 in @ARGV.
362 If $Getopt::Long::order is $REQUIRE_ORDER, options processing
363 terminates when the first non-option is encountered.
365 -foo arg1 -bar arg2 arg3
369 -foo -- arg1 -bar arg2 arg3
371 $RETURN_IN_ORDER is not supported by GetOptions().
373 =item $Getopt::Long::bundling
375 Setting this variable to a non-zero value will allow single-character
376 options to be bundled. To distinguish bundles from long option names,
377 long options must be introduced with B<--> and single-character
378 options (and bundles) with B<->. For example,
382 would be equivalent to
386 provided "vax", "v", "a" and "x" have been defined to be valid
389 Bundled options can also include a value in the bundle; this value has
390 to be the last part of the bundle, e.g.
398 B<Note:> Using option bundling can easily lead to unexpected results,
399 especially when mixing long options and bundles. Caveat emptor.
401 =item $Getopt::Long::ignorecase
403 Ignore case when matching options. Default is 1. When bundling is in
404 effect, case is ignored on single-character options only if
405 $Getopt::Long::ignorecase is greater than 1.
407 =item $Getopt::Long::VERSION
409 The version number of this Getopt::Long implementation in the format
410 C<major>.C<minor>. This can be used to have Exporter check the
413 use Getopt::Long 2.00;
415 You can inspect $Getopt::Long::major_version and
416 $Getopt::Long::minor_version for the individual components.
418 =item $Getopt::Long::error
420 Internal error flag. May be incremented from a call-back routine to
421 cause options parsing to fail.
423 =item $Getopt::Long::debug
425 Enable copious debugging output. Default is 0.
431 ################ Introduction ################
433 # This program is Copyright 1990,1996 by Johan Vromans.
434 # This program is free software; you can redistribute it and/or
435 # modify it under the terms of the GNU General Public License
436 # as published by the Free Software Foundation; either version 2
437 # of the License, or (at your option) any later version.
439 # This program is distributed in the hope that it will be useful,
440 # but WITHOUT ANY WARRANTY; without even the implied warranty of
441 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
442 # GNU General Public License for more details.
444 # If you do not have a copy of the GNU General Public License write to
445 # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
448 ################ Configuration Section ################
450 # Values for $order. See GNU getopt.c for details.
451 ($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
453 my $gen_prefix; # generic prefix (option starters)
455 # Handle POSIX compliancy.
456 if ( defined $ENV{"POSIXLY_CORRECT"} ) {
457 $gen_prefix = "--|-";
458 $autoabbrev = 0; # no automatic abbrev of options
459 $bundling = 0; # no bundling of single letter switches
460 $getopt_compat = 0; # disallow '+' to start options
461 $order = $REQUIRE_ORDER;
464 $gen_prefix = "--|-|\\+";
465 $autoabbrev = 1; # automatic abbrev of options
466 $bundling = 0; # bundling off by default
467 $getopt_compat = 1; # allow '+' to start options
471 # Other configurable settings.
472 $debug = 0; # for debugging
473 $error = 0; # error tally
474 $ignorecase = 1; # ignore case when matching options
475 ($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
477 ################ Subroutines ################
481 my @optionlist = @_; # local copy of the option descriptions
482 my $argend = '--'; # option list terminator
483 my %opctl; # table of arg.specs (long and abbrevs)
484 my %bopctl; # table of arg.specs (bundles)
485 my $pkg = (caller)[0]; # current context
486 # Needed if linkage is omitted.
487 my %aliases; # alias table
488 my @ret = (); # accum for non-options
489 my %linkage; # linkage
490 my $userlinkage; # user supplied HASH
491 my $genprefix = $gen_prefix; # so we can call the same module more
492 # than once in differing environments
495 print STDERR ('GetOptions $Revision: 2.3 $ ',
496 "[GetOpt::Long $Getopt::Long::VERSION] -- ",
497 "called from package \"$pkg\".\n",
498 " autoabbrev=$autoabbrev".
499 ",bundling=$bundling",
500 ",getopt_compat=$getopt_compat",
501 ",genprefix=\"$genprefix\"",
503 ",ignorecase=$ignorecase",
507 # Check for ref HASH as first argument.
508 $userlinkage = undef;
509 if ( ref($optionlist[0]) && ref($optionlist[0]) eq 'HASH' ) {
510 $userlinkage = shift (@optionlist);
513 # See if the first element of the optionlist contains option
514 # starter characters.
515 if ( $optionlist[0] =~ /^\W+$/ ) {
516 $genprefix = shift (@optionlist);
518 $genprefix =~ s/(\W)/\\$1/g;
519 $genprefix = "[" . $genprefix . "]";
522 # Verify correctness of optionlist.
525 while ( @optionlist > 0 ) {
526 my $opt = shift (@optionlist);
528 # Strip leading prefix so people can specify "-foo=i" if they like.
529 $opt = $2 if $opt =~ /^($genprefix)+([\x00-\xff]*)/;
531 if ( $opt eq '<>' ) {
532 if ( (defined $userlinkage)
533 && !(@optionlist > 0 && ref($optionlist[0]))
534 && (exists $userlinkage->{$opt})
535 && ref($userlinkage->{$opt}) ) {
536 unshift (@optionlist, $userlinkage->{$opt});
538 unless ( @optionlist > 0
539 && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
540 warn ("Option spec <> requires a reference to a subroutine\n");
544 $linkage{'<>'} = shift (@optionlist);
548 if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
549 warn ("Error in option spec: \"", $opt, "\"\n");
553 my ($o, $c, $a) = ($1, $2);
554 $c = '' unless defined $c;
556 if ( ! defined $o ) {
557 # empty -> '-' option
558 $opctl{$o = ''} = $c;
562 my @o = split (/\|/, $o);
567 && ($bundling ? length($o) > 1 : 1));
570 if ( $bundling && length($_) == 1 ) {
571 $_ = lc ($_) if $ignorecase > 1;
574 warn ("Ignoring '!' modifier for short option $_\n");
580 $_ = lc ($_) if $ignorecase;
598 # If no linkage is supplied in the @optionlist, copy it from
599 # the userlinkage if available.
600 if ( defined $userlinkage ) {
601 unless ( @optionlist > 0 && ref($optionlist[0]) ) {
602 if ( exists $userlinkage->{$o} && ref($userlinkage->{$o}) ) {
603 print STDERR ("=> found userlinkage for \"$o\": ",
604 "$userlinkage->{$o}\n")
606 unshift (@optionlist, $userlinkage->{$o});
609 # Do nothing. Being undefined will be handled later.
615 # Copy the linkage. If omitted, link to global variable.
616 if ( @optionlist > 0 && ref($optionlist[0]) ) {
617 print STDERR ("=> link \"$o\" to $optionlist[0]\n")
619 if ( ref($optionlist[0]) =~ /^(SCALAR|ARRAY|CODE)$/ ) {
620 $linkage{$o} = shift (@optionlist);
623 warn ("Invalid option linkage for \"", $opt, "\"\n");
628 # Link to global $opt_XXX variable.
629 # Make sure a valid perl identifier results.
632 if ( defined($c) && $c =~ /@/ ) {
633 print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n")
635 eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;");
638 print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n")
640 eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;");
645 # Bail out if errors found.
648 # Sort the possible long option names.
649 my @opctl = sort(keys (%opctl)) if $autoabbrev;
651 # Show the options tables if debugging.
655 while ( ($k,$v) = each(%opctl) ) {
656 print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
660 while ( ($k,$v) = each(%bopctl) ) {
661 print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n");
666 my $opt; # current option
667 my $arg; # current option value, if any
668 my $array; # current option is array typed
670 # Process argument list
671 while ( @ARGV > 0 ) {
673 # >>> See also the continue block <<<
675 #### Get next argument ####
677 my $starter; # option starter string, e.g. '-' or '--'
678 my $rest = undef; # remainder from unbundling
679 my $optarg = undef; # value supplied with --opt=value
681 $opt = shift (@ARGV);
684 print STDERR ("=> option \"", $opt, "\"\n") if $debug;
686 #### Determine what we have ####
688 # Double dash is option list terminator.
689 if ( $opt eq $argend ) {
690 # Finish. Push back accumulated arguments and return.
691 unshift (@ARGV, @ret)
692 if $order == $PERMUTE;
693 return ($error == 0);
696 if ( $opt =~ /^($genprefix)([\x00-\xff]*)/ ) {
697 # Looks like an option.
698 $opt = $2; # option name (w/o prefix)
699 $starter = $1; # option starter
701 # If it is a long option, it may include the value.
702 if (($starter eq "--"
703 || ($getopt_compat && $starter eq "+"))
704 && $opt =~ /^([^=]+)=([\x00-\xff]*)/ ) {
707 print STDERR ("=> option \"", $opt,
708 "\", optarg = \"$optarg\"\n") if $debug;
713 # Not an option. Save it if we $PERMUTE and don't have a <>.
714 elsif ( $order == $PERMUTE ) {
715 # Try non-options call-back.
717 if ( (defined ($cb = $linkage{'<>'})) ) {
721 print STDERR ("=> saving \"$opt\" ",
722 "(not an option, may permute)\n") if $debug;
728 # ...otherwise, terminate.
730 # Push this one back and exit.
731 unshift (@ARGV, $opt);
732 return ($error == 0);
737 my $tryopt = $opt; # option to try
738 my $optbl = \%opctl; # table to look it up (long names)
740 if ( $bundling && $starter eq '-' ) {
741 # Unbundle single letter option.
742 $rest = substr ($tryopt, 1);
743 $tryopt = substr ($tryopt, 0, 1);
744 $tryopt = lc ($tryopt) if $ignorecase > 1;
745 print STDERR ("=> $starter$tryopt unbundled from ",
746 "$starter$tryopt$rest\n") if $debug;
747 $rest = undef unless $rest ne '';
748 $optbl = \%bopctl; # look it up in the short names table
751 # Try auto-abbreviation.
752 elsif ( $autoabbrev ) {
753 # Downcase if allowed.
754 $tryopt = $opt = lc ($opt) if $ignorecase;
755 # Turn option name into pattern.
756 my $pat = quotemeta ($opt);
757 # Look up in option names.
758 my @hits = grep (/^$pat/, @opctl);
759 print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
760 "out of ", scalar(@opctl), "\n") if $debug;
762 # Check for ambiguous results.
763 unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
764 print STDERR ("Option ", $opt, " is ambiguous (",
765 join(", ", @hits), ")\n");
770 # Complete the option name, if appropriate.
771 if ( @hits == 1 && $hits[0] ne $opt ) {
773 print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
778 # Check validity by fetching the info.
779 my $type = $optbl->{$tryopt};
780 unless ( defined $type ) {
781 warn ("Unknown option: ", $opt, "\n");
787 print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
789 #### Determine argument status ####
791 # If it is an option w/o argument, we're almost finished with it.
792 if ( $type eq '' || $type eq '!' ) {
793 if ( defined $optarg ) {
794 print STDERR ("Option ", $opt, " does not take an argument\n");
797 elsif ( $type eq '' ) {
798 $arg = 1; # supply explicit value
801 substr ($opt, 0, 2) = ''; # strip NO prefix
802 $arg = 0; # supply explicit value
804 # When unbundling, unshift the rest with the starter.
805 unshift (@ARGV, $starter.$rest) if defined $rest;
809 # Get mandatory status and type info.
811 ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
813 # Check if there is an option argument available.
814 if ( defined $optarg ? ($optarg eq '')
815 : !(defined $rest || @ARGV > 0) ) {
816 # Complain if this option needs an argument.
817 if ( $mand eq "=" ) {
818 print STDERR ("Option ", $opt, " requires an argument\n");
821 if ( $mand eq ":" ) {
822 $arg = $type eq "s" ? '' : 0;
827 # Get (possibly optional) argument.
828 $arg = (defined $rest ? $rest
829 : (defined $optarg ? $optarg : shift (@ARGV)));
831 #### Check if the argument is valid for this option ####
833 if ( $type eq "s" ) { # string
834 # A mandatory string takes anything.
835 next if $mand eq "=";
837 # An optional string takes almost anything.
838 next if defined $optarg || defined $rest;
839 next if $arg eq "-"; # ??
841 # Check for option or option list terminator.
842 if ($arg eq $argend ||
843 $arg =~ /^$genprefix.+/) {
845 unshift (@ARGV, $arg);
846 # Supply empty value.
852 if ( $type eq "n" || $type eq "i" ) { # numeric/integer
853 if ( $arg !~ /^-?[0-9]+$/ ) {
854 if ( defined $optarg || $mand eq "=" ) {
855 print STDERR ("Value \"", $arg, "\" invalid for option ",
856 $opt, " (number expected)\n");
858 undef $arg; # don't assign it
860 unshift (@ARGV, $starter.$rest) if defined $rest;
864 unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
865 # Supply default value.
872 if ( $type eq "f" ) { # fixed real number, int is also ok
873 if ( $arg !~ /^-?[0-9.]+$/ ) {
874 if ( defined $optarg || $mand eq "=" ) {
875 print STDERR ("Value \"", $arg, "\" invalid for option ",
876 $opt, " (real number expected)\n");
878 undef $arg; # don't assign it
880 unshift (@ARGV, $starter.$rest) if defined $rest;
884 unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
885 # Supply default value.
892 die ("GetOpt::Long internal error (Can't happen)\n");
896 if ( defined $arg ) {
897 $opt = $aliases{$opt} if defined $aliases{$opt};
899 if ( defined $linkage{$opt} ) {
900 print STDERR ("=> ref(\$L{$opt}) -> ",
901 ref($linkage{$opt}), "\n") if $debug;
903 if ( ref($linkage{$opt}) eq 'SCALAR' ) {
904 print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug;
905 ${$linkage{$opt}} = $arg;
907 elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
908 print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
910 push (@{$linkage{$opt}}, $arg);
912 elsif ( ref($linkage{$opt}) eq 'CODE' ) {
913 print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n")
915 &{$linkage{$opt}}($opt, $arg);
918 print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
920 die ("Getopt::Long -- internal error!\n");
923 # No entry in linkage means entry in userlinkage.
925 if ( defined $userlinkage->{$opt} ) {
926 print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
928 push (@{$userlinkage->{$opt}}, $arg);
931 print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
933 $userlinkage->{$opt} = [$arg];
937 print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
938 $userlinkage->{$opt} = $arg;
944 if ( $order == $PERMUTE ) {
945 # Push back accumulated arguments
946 print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
947 if $debug && @ret > 0;
948 unshift (@ARGV, @ret) if @ret > 0;
951 return ($error == 0);
954 ################ Package return ################