home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / Getopt / Long.pm next >
Encoding:
Perl POD Document  |  2009-06-26  |  40.1 KB  |  1,492 lines

  1. # Getopt::Long.pm -- Universal options parsing
  2.  
  3. package Getopt::Long;
  4.  
  5. # RCS Status      : $Id: Long.pm,v 2.74 2007/09/29 13:40:13 jv Exp $
  6. # Author          : Johan Vromans
  7. # Created On      : Tue Sep 11 15:00:12 1990
  8. # Last Modified By: Johan Vromans
  9. # Last Modified On: Sat Sep 29 15:38:55 2007
  10. # Update Count    : 1571
  11. # Status          : Released
  12.  
  13. ################ Copyright ################
  14.  
  15. # This program is Copyright 1990,2007 by Johan Vromans.
  16. # This program is free software; you can redistribute it and/or
  17. # modify it under the terms of the Perl Artistic License or the
  18. # GNU General Public License as published by the Free Software
  19. # Foundation; either version 2 of the License, or (at your option) any
  20. # later version.
  21. #
  22. # This program is distributed in the hope that it will be useful,
  23. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  24. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  25. # GNU General Public License for more details.
  26. #
  27. # If you do not have a copy of the GNU General Public License write to
  28. # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
  29. # MA 02139, USA.
  30.  
  31. ################ Module Preamble ################
  32.  
  33. use 5.004;
  34.  
  35. use strict;
  36.  
  37. use vars qw($VERSION);
  38. $VERSION        =  2.37;
  39. # For testing versions only.
  40. use vars qw($VERSION_STRING);
  41. $VERSION_STRING = "2.37";
  42.  
  43. use Exporter;
  44. use vars qw(@ISA @EXPORT @EXPORT_OK);
  45. @ISA = qw(Exporter);
  46.  
  47. # Exported subroutines.
  48. sub GetOptions(@);        # always
  49. sub GetOptionsFromArray($@);    # on demand
  50. sub GetOptionsFromString($@);    # on demand
  51. sub Configure(@);        # on demand
  52. sub HelpMessage(@);        # on demand
  53. sub VersionMessage(@);        # in demand
  54.  
  55. BEGIN {
  56.     # Init immediately so their contents can be used in the 'use vars' below.
  57.     @EXPORT    = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
  58.     @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure
  59.             &GetOptionsFromArray &GetOptionsFromString);
  60. }
  61.  
  62. # User visible variables.
  63. use vars @EXPORT, @EXPORT_OK;
  64. use vars qw($error $debug $major_version $minor_version);
  65. # Deprecated visible variables.
  66. use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
  67.         $passthrough);
  68. # Official invisible variables.
  69. use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);
  70.  
  71. # Public subroutines.
  72. sub config(@);            # deprecated name
  73.  
  74. # Private subroutines.
  75. sub ConfigDefaults();
  76. sub ParseOptionSpec($$);
  77. sub OptCtl($);
  78. sub FindOption($$$$$);
  79. sub ValidValue ($$$$$);
  80.  
  81. ################ Local Variables ################
  82.  
  83. # $requested_version holds the version that was mentioned in the 'use'
  84. # or 'require', if any. It can be used to enable or disable specific
  85. # features.
  86. my $requested_version = 0;
  87.  
  88. ################ Resident subroutines ################
  89.  
  90. sub ConfigDefaults() {
  91.     # Handle POSIX compliancy.
  92.     if ( defined $ENV{"POSIXLY_CORRECT"} ) {
  93.     $genprefix = "(--|-)";
  94.     $autoabbrev = 0;        # no automatic abbrev of options
  95.     $bundling = 0;            # no bundling of single letter switches
  96.     $getopt_compat = 0;        # disallow '+' to start options
  97.     $order = $REQUIRE_ORDER;
  98.     }
  99.     else {
  100.     $genprefix = "(--|-|\\+)";
  101.     $autoabbrev = 1;        # automatic abbrev of options
  102.     $bundling = 0;            # bundling off by default
  103.     $getopt_compat = 1;        # allow '+' to start options
  104.     $order = $PERMUTE;
  105.     }
  106.     # Other configurable settings.
  107.     $debug = 0;            # for debugging
  108.     $error = 0;            # error tally
  109.     $ignorecase = 1;        # ignore case when matching options
  110.     $passthrough = 0;        # leave unrecognized options alone
  111.     $gnu_compat = 0;        # require --opt=val if value is optional
  112.     $longprefix = "(--)";       # what does a long prefix look like
  113. }
  114.  
  115. # Override import.
  116. sub import {
  117.     my $pkg = shift;        # package
  118.     my @syms = ();        # symbols to import
  119.     my @config = ();        # configuration
  120.     my $dest = \@syms;        # symbols first
  121.     for ( @_ ) {
  122.     if ( $_ eq ':config' ) {
  123.         $dest = \@config;    # config next
  124.         next;
  125.     }
  126.     push(@$dest, $_);    # push
  127.     }
  128.     # Hide one level and call super.
  129.     local $Exporter::ExportLevel = 1;
  130.     push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions
  131.     $pkg->SUPER::import(@syms);
  132.     # And configure.
  133.     Configure(@config) if @config;
  134. }
  135.  
  136. ################ Initialization ################
  137.  
  138. # Values for $order. See GNU getopt.c for details.
  139. ($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
  140. # Version major/minor numbers.
  141. ($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
  142.  
  143. ConfigDefaults();
  144.  
  145. ################ OO Interface ################
  146.  
  147. package Getopt::Long::Parser;
  148.  
  149. # Store a copy of the default configuration. Since ConfigDefaults has
  150. # just been called, what we get from Configure is the default.
  151. my $default_config = do {
  152.     Getopt::Long::Configure ()
  153. };
  154.  
  155. sub new {
  156.     my $that = shift;
  157.     my $class = ref($that) || $that;
  158.     my %atts = @_;
  159.  
  160.     # Register the callers package.
  161.     my $self = { caller_pkg => (caller)[0] };
  162.  
  163.     bless ($self, $class);
  164.  
  165.     # Process config attributes.
  166.     if ( defined $atts{config} ) {
  167.     my $save = Getopt::Long::Configure ($default_config, @{$atts{config}});
  168.     $self->{settings} = Getopt::Long::Configure ($save);
  169.     delete ($atts{config});
  170.     }
  171.     # Else use default config.
  172.     else {
  173.     $self->{settings} = $default_config;
  174.     }
  175.  
  176.     if ( %atts ) {        # Oops
  177.     die(__PACKAGE__.": unhandled attributes: ".
  178.         join(" ", sort(keys(%atts)))."\n");
  179.     }
  180.  
  181.     $self;
  182. }
  183.  
  184. sub configure {
  185.     my ($self) = shift;
  186.  
  187.     # Restore settings, merge new settings in.
  188.     my $save = Getopt::Long::Configure ($self->{settings}, @_);
  189.  
  190.     # Restore orig config and save the new config.
  191.     $self->{settings} = Getopt::Long::Configure ($save);
  192. }
  193.  
  194. sub getoptions {
  195.     my ($self) = shift;
  196.  
  197.     # Restore config settings.
  198.     my $save = Getopt::Long::Configure ($self->{settings});
  199.  
  200.     # Call main routine.
  201.     my $ret = 0;
  202.     $Getopt::Long::caller = $self->{caller_pkg};
  203.  
  204.     eval {
  205.     # Locally set exception handler to default, otherwise it will
  206.     # be called implicitly here, and again explicitly when we try
  207.     # to deliver the messages.
  208.     local ($SIG{__DIE__}) = '__DEFAULT__';
  209.     $ret = Getopt::Long::GetOptions (@_);
  210.     };
  211.  
  212.     # Restore saved settings.
  213.     Getopt::Long::Configure ($save);
  214.  
  215.     # Handle errors and return value.
  216.     die ($@) if $@;
  217.     return $ret;
  218. }
  219.  
  220. package Getopt::Long;
  221.  
  222. ################ Back to Normal ################
  223.  
  224. # Indices in option control info.
  225. # Note that ParseOptions uses the fields directly. Search for 'hard-wired'.
  226. use constant CTL_TYPE    => 0;
  227. #use constant   CTL_TYPE_FLAG   => '';
  228. #use constant   CTL_TYPE_NEG    => '!';
  229. #use constant   CTL_TYPE_INCR   => '+';
  230. #use constant   CTL_TYPE_INT    => 'i';
  231. #use constant   CTL_TYPE_INTINC => 'I';
  232. #use constant   CTL_TYPE_XINT   => 'o';
  233. #use constant   CTL_TYPE_FLOAT  => 'f';
  234. #use constant   CTL_TYPE_STRING => 's';
  235.  
  236. use constant CTL_CNAME   => 1;
  237.  
  238. use constant CTL_DEFAULT => 2;
  239.  
  240. use constant CTL_DEST    => 3;
  241.  use constant   CTL_DEST_SCALAR => 0;
  242.  use constant   CTL_DEST_ARRAY  => 1;
  243.  use constant   CTL_DEST_HASH   => 2;
  244.  use constant   CTL_DEST_CODE   => 3;
  245.  
  246. use constant CTL_AMIN    => 4;
  247. use constant CTL_AMAX    => 5;
  248.  
  249. # FFU.
  250. #use constant CTL_RANGE   => ;
  251. #use constant CTL_REPEAT  => ;
  252.  
  253. # Rather liberal patterns to match numbers.
  254. use constant PAT_INT   => "[-+]?_*[0-9][0-9_]*";
  255. use constant PAT_XINT  =>
  256.   "(?:".
  257.       "[-+]?_*[1-9][0-9_]*".
  258.   "|".
  259.       "0x_*[0-9a-f][0-9a-f_]*".
  260.   "|".
  261.       "0b_*[01][01_]*".
  262.   "|".
  263.       "0[0-7_]*".
  264.   ")";
  265. use constant PAT_FLOAT => "[-+]?[0-9._]+(\.[0-9_]+)?([eE][-+]?[0-9_]+)?";
  266.  
  267. sub GetOptions(@) {
  268.     # Shift in default array.
  269.     unshift(@_, \@ARGV);
  270.     # Try to keep caller() and Carp consitent.
  271.     goto &GetOptionsFromArray;
  272. }
  273.  
  274. sub GetOptionsFromString($@) {
  275.     my ($string) = shift;
  276.     require Text::ParseWords;
  277.     my $args = [ Text::ParseWords::shellwords($string) ];
  278.     $caller ||= (caller)[0];    # current context
  279.     my $ret = GetOptionsFromArray($args, @_);
  280.     return ( $ret, $args ) if wantarray;
  281.     if ( @$args ) {
  282.     $ret = 0;
  283.     warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
  284.     }
  285.     $ret;
  286. }
  287.  
  288. sub GetOptionsFromArray($@) {
  289.  
  290.     my ($argv, @optionlist) = @_;    # local copy of the option descriptions
  291.     my $argend = '--';        # option list terminator
  292.     my %opctl = ();        # table of option specs
  293.     my $pkg = $caller || (caller)[0];    # current context
  294.                 # Needed if linkage is omitted.
  295.     my @ret = ();        # accum for non-options
  296.     my %linkage;        # linkage
  297.     my $userlinkage;        # user supplied HASH
  298.     my $opt;            # current option
  299.     my $prefix = $genprefix;    # current prefix
  300.  
  301.     $error = '';
  302.  
  303.     if ( $debug ) {
  304.     # Avoid some warnings if debugging.
  305.     local ($^W) = 0;
  306.     print STDERR
  307.       ("Getopt::Long $Getopt::Long::VERSION (",
  308.        '$Revision: 2.74 $', ") ",
  309.        "called from package \"$pkg\".",
  310.        "\n  ",
  311.        "argv: (@$argv)",
  312.        "\n  ",
  313.        "autoabbrev=$autoabbrev,".
  314.        "bundling=$bundling,",
  315.        "getopt_compat=$getopt_compat,",
  316.        "gnu_compat=$gnu_compat,",
  317.        "order=$order,",
  318.        "\n  ",
  319.        "ignorecase=$ignorecase,",
  320.        "requested_version=$requested_version,",
  321.        "passthrough=$passthrough,",
  322.        "genprefix=\"$genprefix\",",
  323.        "longprefix=\"$longprefix\".",
  324.        "\n");
  325.     }
  326.  
  327.     # Check for ref HASH as first argument.
  328.     # First argument may be an object. It's OK to use this as long
  329.     # as it is really a hash underneath.
  330.     $userlinkage = undef;
  331.     if ( @optionlist && ref($optionlist[0]) and
  332.      UNIVERSAL::isa($optionlist[0],'HASH') ) {
  333.     $userlinkage = shift (@optionlist);
  334.     print STDERR ("=> user linkage: $userlinkage\n") if $debug;
  335.     }
  336.  
  337.     # See if the first element of the optionlist contains option
  338.     # starter characters.
  339.     # Be careful not to interpret '<>' as option starters.
  340.     if ( @optionlist && $optionlist[0] =~ /^\W+$/
  341.      && !($optionlist[0] eq '<>'
  342.           && @optionlist > 0
  343.           && ref($optionlist[1])) ) {
  344.     $prefix = shift (@optionlist);
  345.     # Turn into regexp. Needs to be parenthesized!
  346.     $prefix =~ s/(\W)/\\$1/g;
  347.     $prefix = "([" . $prefix . "])";
  348.     print STDERR ("=> prefix=\"$prefix\"\n") if $debug;
  349.     }
  350.  
  351.     # Verify correctness of optionlist.
  352.     %opctl = ();
  353.     while ( @optionlist ) {
  354.     my $opt = shift (@optionlist);
  355.  
  356.     unless ( defined($opt) ) {
  357.         $error .= "Undefined argument in option spec\n";
  358.         next;
  359.     }
  360.  
  361.     # Strip leading prefix so people can specify "--foo=i" if they like.
  362.     $opt = $+ if $opt =~ /^$prefix+(.*)$/s;
  363.  
  364.     if ( $opt eq '<>' ) {
  365.         if ( (defined $userlinkage)
  366.         && !(@optionlist > 0 && ref($optionlist[0]))
  367.         && (exists $userlinkage->{$opt})
  368.         && ref($userlinkage->{$opt}) ) {
  369.         unshift (@optionlist, $userlinkage->{$opt});
  370.         }
  371.         unless ( @optionlist > 0
  372.             && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
  373.         $error .= "Option spec <> requires a reference to a subroutine\n";
  374.         # Kill the linkage (to avoid another error).
  375.         shift (@optionlist)
  376.           if @optionlist && ref($optionlist[0]);
  377.         next;
  378.         }
  379.         $linkage{'<>'} = shift (@optionlist);
  380.         next;
  381.     }
  382.  
  383.     # Parse option spec.
  384.     my ($name, $orig) = ParseOptionSpec ($opt, \%opctl);
  385.     unless ( defined $name ) {
  386.         # Failed. $orig contains the error message. Sorry for the abuse.
  387.         $error .= $orig;
  388.         # Kill the linkage (to avoid another error).
  389.         shift (@optionlist)
  390.           if @optionlist && ref($optionlist[0]);
  391.         next;
  392.     }
  393.  
  394.     # If no linkage is supplied in the @optionlist, copy it from
  395.     # the userlinkage if available.
  396.     if ( defined $userlinkage ) {
  397.         unless ( @optionlist > 0 && ref($optionlist[0]) ) {
  398.         if ( exists $userlinkage->{$orig} &&
  399.              ref($userlinkage->{$orig}) ) {
  400.             print STDERR ("=> found userlinkage for \"$orig\": ",
  401.                   "$userlinkage->{$orig}\n")
  402.             if $debug;
  403.             unshift (@optionlist, $userlinkage->{$orig});
  404.         }
  405.         else {
  406.             # Do nothing. Being undefined will be handled later.
  407.             next;
  408.         }
  409.         }
  410.     }
  411.  
  412.     # Copy the linkage. If omitted, link to global variable.
  413.     if ( @optionlist > 0 && ref($optionlist[0]) ) {
  414.         print STDERR ("=> link \"$orig\" to $optionlist[0]\n")
  415.         if $debug;
  416.         my $rl = ref($linkage{$orig} = shift (@optionlist));
  417.  
  418.         if ( $rl eq "ARRAY" ) {
  419.         $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY;
  420.         }
  421.         elsif ( $rl eq "HASH" ) {
  422.         $opctl{$name}[CTL_DEST] = CTL_DEST_HASH;
  423.         }
  424.         elsif ( $rl eq "SCALAR" || $rl eq "REF" ) {
  425. #        if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
  426. #            my $t = $linkage{$orig};
  427. #            $$t = $linkage{$orig} = [];
  428. #        }
  429. #        elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
  430. #        }
  431. #        else {
  432.             # Ok.
  433. #        }
  434.         }
  435.         elsif ( $rl eq "CODE" ) {
  436.         # Ok.
  437.         }
  438.         else {
  439.         $error .= "Invalid option linkage for \"$opt\"\n";
  440.         }
  441.     }
  442.     else {
  443.         # Link to global $opt_XXX variable.
  444.         # Make sure a valid perl identifier results.
  445.         my $ov = $orig;
  446.         $ov =~ s/\W/_/g;
  447.         if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
  448.         print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n")
  449.             if $debug;
  450.         eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;");
  451.         }
  452.         elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
  453.         print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n")
  454.             if $debug;
  455.         eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;");
  456.         }
  457.         else {
  458.         print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n")
  459.             if $debug;
  460.         eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;");
  461.         }
  462.     }
  463.     }
  464.  
  465.     # Bail out if errors found.
  466.     die ($error) if $error;
  467.     $error = 0;
  468.  
  469.     # Supply --version and --help support, if needed and allowed.
  470.     if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) {
  471.     if ( !defined($opctl{version}) ) {
  472.         $opctl{version} = ['','version',0,CTL_DEST_CODE,undef];
  473.         $linkage{version} = \&VersionMessage;
  474.     }
  475.     $auto_version = 1;
  476.     }
  477.     if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) {
  478.     if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) {
  479.         $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef];
  480.         $linkage{help} = \&HelpMessage;
  481.     }
  482.     $auto_help = 1;
  483.     }
  484.  
  485.     # Show the options tables if debugging.
  486.     if ( $debug ) {
  487.     my ($arrow, $k, $v);
  488.     $arrow = "=> ";
  489.     while ( ($k,$v) = each(%opctl) ) {
  490.         print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n");
  491.         $arrow = "   ";
  492.     }
  493.     }
  494.  
  495.     # Process argument list
  496.     my $goon = 1;
  497.     while ( $goon && @$argv > 0 ) {
  498.  
  499.     # Get next argument.
  500.     $opt = shift (@$argv);
  501.     print STDERR ("=> arg \"", $opt, "\"\n") if $debug;
  502.  
  503.     # Double dash is option list terminator.
  504.     if ( $opt eq $argend ) {
  505.       push (@ret, $argend) if $passthrough;
  506.       last;
  507.     }
  508.  
  509.     # Look it up.
  510.     my $tryopt = $opt;
  511.     my $found;        # success status
  512.     my $key;        # key (if hash type)
  513.     my $arg;        # option argument
  514.     my $ctl;        # the opctl entry
  515.  
  516.     ($found, $opt, $ctl, $arg, $key) =
  517.       FindOption ($argv, $prefix, $argend, $opt, \%opctl);
  518.  
  519.     if ( $found ) {
  520.  
  521.         # FindOption undefines $opt in case of errors.
  522.         next unless defined $opt;
  523.  
  524.         my $argcnt = 0;
  525.         while ( defined $arg ) {
  526.  
  527.         # Get the canonical name.
  528.         print STDERR ("=> cname for \"$opt\" is ") if $debug;
  529.         $opt = $ctl->[CTL_CNAME];
  530.         print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug;
  531.  
  532.         if ( defined $linkage{$opt} ) {
  533.             print STDERR ("=> ref(\$L{$opt}) -> ",
  534.                   ref($linkage{$opt}), "\n") if $debug;
  535.  
  536.             if ( ref($linkage{$opt}) eq 'SCALAR'
  537.              || ref($linkage{$opt}) eq 'REF' ) {
  538.             if ( $ctl->[CTL_TYPE] eq '+' ) {
  539.                 print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
  540.                   if $debug;
  541.                 if ( defined ${$linkage{$opt}} ) {
  542.                     ${$linkage{$opt}} += $arg;
  543.                 }
  544.                     else {
  545.                     ${$linkage{$opt}} = $arg;
  546.                 }
  547.             }
  548.             elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
  549.                 print STDERR ("=> ref(\$L{$opt}) auto-vivified",
  550.                       " to ARRAY\n")
  551.                   if $debug;
  552.                 my $t = $linkage{$opt};
  553.                 $$t = $linkage{$opt} = [];
  554.                 print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
  555.                   if $debug;
  556.                 push (@{$linkage{$opt}}, $arg);
  557.             }
  558.             elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
  559.                 print STDERR ("=> ref(\$L{$opt}) auto-vivified",
  560.                       " to HASH\n")
  561.                   if $debug;
  562.                 my $t = $linkage{$opt};
  563.                 $$t = $linkage{$opt} = {};
  564.                 print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
  565.                   if $debug;
  566.                 $linkage{$opt}->{$key} = $arg;
  567.             }
  568.             else {
  569.                 print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
  570.                   if $debug;
  571.                 ${$linkage{$opt}} = $arg;
  572.                 }
  573.             }
  574.             elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
  575.             print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
  576.                 if $debug;
  577.             push (@{$linkage{$opt}}, $arg);
  578.             }
  579.             elsif ( ref($linkage{$opt}) eq 'HASH' ) {
  580.             print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
  581.                 if $debug;
  582.             $linkage{$opt}->{$key} = $arg;
  583.             }
  584.             elsif ( ref($linkage{$opt}) eq 'CODE' ) {
  585.             print STDERR ("=> &L{$opt}(\"$opt\"",
  586.                       $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
  587.                       ", \"$arg\")\n")
  588.                 if $debug;
  589.             my $eval_error = do {
  590.                 local $@;
  591.                 local $SIG{__DIE__}  = '__DEFAULT__';
  592.                 eval {
  593.                 &{$linkage{$opt}}
  594.                   (Getopt::Long::CallBack->new
  595.                    (name    => $opt,
  596.                     ctl     => $ctl,
  597.                     opctl   => \%opctl,
  598.                     linkage => \%linkage,
  599.                     prefix  => $prefix,
  600.                    ),
  601.                    $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
  602.                    $arg);
  603.                 };
  604.                 $@;
  605.             };
  606.             print STDERR ("=> die($eval_error)\n")
  607.               if $debug && $eval_error ne '';
  608.             if ( $eval_error =~ /^!/ ) {
  609.                 if ( $eval_error =~ /^!FINISH\b/ ) {
  610.                 $goon = 0;
  611.                 }
  612.             }
  613.             elsif ( $eval_error ne '' ) {
  614.                 warn ($eval_error);
  615.                 $error++;
  616.             }
  617.             }
  618.             else {
  619.             print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
  620.                       "\" in linkage\n");
  621.             die("Getopt::Long -- internal error!\n");
  622.             }
  623.         }
  624.         # No entry in linkage means entry in userlinkage.
  625.         elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
  626.             if ( defined $userlinkage->{$opt} ) {
  627.             print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
  628.                 if $debug;
  629.             push (@{$userlinkage->{$opt}}, $arg);
  630.             }
  631.             else {
  632.             print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
  633.                 if $debug;
  634.             $userlinkage->{$opt} = [$arg];
  635.             }
  636.         }
  637.         elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
  638.             if ( defined $userlinkage->{$opt} ) {
  639.             print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
  640.                 if $debug;
  641.             $userlinkage->{$opt}->{$key} = $arg;
  642.             }
  643.             else {
  644.             print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
  645.                 if $debug;
  646.             $userlinkage->{$opt} = {$key => $arg};
  647.             }
  648.         }
  649.         else {
  650.             if ( $ctl->[CTL_TYPE] eq '+' ) {
  651.             print STDERR ("=> \$L{$opt} += \"$arg\"\n")
  652.               if $debug;
  653.             if ( defined $userlinkage->{$opt} ) {
  654.                 $userlinkage->{$opt} += $arg;
  655.             }
  656.             else {
  657.                 $userlinkage->{$opt} = $arg;
  658.             }
  659.             }
  660.             else {
  661.             print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
  662.             $userlinkage->{$opt} = $arg;
  663.             }
  664.         }
  665.  
  666.         $argcnt++;
  667.         last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
  668.         undef($arg);
  669.  
  670.         # Need more args?
  671.         if ( $argcnt < $ctl->[CTL_AMIN] ) {
  672.             if ( @$argv ) {
  673.             if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) {
  674.                 $arg = shift(@$argv);
  675.                 $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/;
  676.                 ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
  677.                   if $ctl->[CTL_DEST] == CTL_DEST_HASH;
  678.                 next;
  679.             }
  680.             warn("Value \"$$argv[0]\" invalid for option $opt\n");
  681.             $error++;
  682.             }
  683.             else {
  684.             warn("Insufficient arguments for option $opt\n");
  685.             $error++;
  686.             }
  687.         }
  688.  
  689.         # Any more args?
  690.         if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) {
  691.             $arg = shift(@$argv);
  692.             $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/;
  693.             ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
  694.               if $ctl->[CTL_DEST] == CTL_DEST_HASH;
  695.             next;
  696.         }
  697.         }
  698.     }
  699.  
  700.     # Not an option. Save it if we $PERMUTE and don't have a <>.
  701.     elsif ( $order == $PERMUTE ) {
  702.         # Try non-options call-back.
  703.         my $cb;
  704.         if ( (defined ($cb = $linkage{'<>'})) ) {
  705.         print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
  706.           if $debug;
  707.         my $eval_error = do {
  708.             local $@;
  709.             local $SIG{__DIE__}  = '__DEFAULT__';
  710.             eval { &$cb ($tryopt) };
  711.             $@;
  712.         };
  713.         print STDERR ("=> die($eval_error)\n")
  714.           if $debug && $eval_error ne '';
  715.         if ( $eval_error =~ /^!/ ) {
  716.             if ( $eval_error =~ /^!FINISH\b/ ) {
  717.             $goon = 0;
  718.             }
  719.         }
  720.         elsif ( $eval_error ne '' ) {
  721.             warn ($eval_error);
  722.             $error++;
  723.         }
  724.         }
  725.         else {
  726.         print STDERR ("=> saving \"$tryopt\" ",
  727.                   "(not an option, may permute)\n") if $debug;
  728.         push (@ret, $tryopt);
  729.         }
  730.         next;
  731.     }
  732.  
  733.     # ...otherwise, terminate.
  734.     else {
  735.         # Push this one back and exit.
  736.         unshift (@$argv, $tryopt);
  737.         return ($error == 0);
  738.     }
  739.  
  740.     }
  741.  
  742.     # Finish.
  743.     if ( @ret && $order == $PERMUTE ) {
  744.     #  Push back accumulated arguments
  745.     print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
  746.         if $debug;
  747.     unshift (@$argv, @ret);
  748.     }
  749.  
  750.     return ($error == 0);
  751. }
  752.  
  753. # A readable representation of what's in an optbl.
  754. sub OptCtl ($) {
  755.     my ($v) = @_;
  756.     my @v = map { defined($_) ? ($_) : ("<undef>") } @$v;
  757.     "[".
  758.       join(",",
  759.        "\"$v[CTL_TYPE]\"",
  760.        "\"$v[CTL_CNAME]\"",
  761.        "\"$v[CTL_DEFAULT]\"",
  762.        ("\$","\@","\%","\&")[$v[CTL_DEST] || 0],
  763.        $v[CTL_AMIN] || '',
  764.        $v[CTL_AMAX] || '',
  765. #       $v[CTL_RANGE] || '',
  766. #       $v[CTL_REPEAT] || '',
  767.       ). "]";
  768. }
  769.  
  770. # Parse an option specification and fill the tables.
  771. sub ParseOptionSpec ($$) {
  772.     my ($opt, $opctl) = @_;
  773.  
  774.     # Match option spec.
  775.     if ( $opt !~ m;^
  776.            (
  777.              # Option name
  778.              (?: \w+[-\w]* )
  779.              # Alias names, or "?"
  780.              (?: \| (?: \? | \w[-\w]* )? )*
  781.            )?
  782.            (
  783.              # Either modifiers ...
  784.              [!+]
  785.              |
  786.              # ... or a value/dest/repeat specification
  787.              [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
  788.              |
  789.              # ... or an optional-with-default spec
  790.              : (?: -?\d+ | \+ ) [@%]?
  791.            )?
  792.            $;x ) {
  793.     return (undef, "Error in option spec: \"$opt\"\n");
  794.     }
  795.  
  796.     my ($names, $spec) = ($1, $2);
  797.     $spec = '' unless defined $spec;
  798.  
  799.     # $orig keeps track of the primary name the user specified.
  800.     # This name will be used for the internal or external linkage.
  801.     # In other words, if the user specifies "FoO|BaR", it will
  802.     # match any case combinations of 'foo' and 'bar', but if a global
  803.     # variable needs to be set, it will be $opt_FoO in the exact case
  804.     # as specified.
  805.     my $orig;
  806.  
  807.     my @names;
  808.     if ( defined $names ) {
  809.     @names =  split (/\|/, $names);
  810.     $orig = $names[0];
  811.     }
  812.     else {
  813.     @names = ('');
  814.     $orig = '';
  815.     }
  816.  
  817.     # Construct the opctl entries.
  818.     my $entry;
  819.     if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
  820.     # Fields are hard-wired here.
  821.     $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0];
  822.     }
  823.     elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) {
  824.     my $def = $1;
  825.     my $dest = $2;
  826.     my $type = $def eq '+' ? 'I' : 'i';
  827.     $dest ||= '$';
  828.     $dest = $dest eq '@' ? CTL_DEST_ARRAY
  829.       : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
  830.     # Fields are hard-wired here.
  831.     $entry = [$type,$orig,$def eq '+' ? undef : $def,
  832.           $dest,0,1];
  833.     }
  834.     else {
  835.     my ($mand, $type, $dest) =
  836.       $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
  837.     return (undef, "Cannot repeat while bundling: \"$opt\"\n")
  838.       if $bundling && defined($4);
  839.     my ($mi, $cm, $ma) = ($5, $6, $7);
  840.     return (undef, "{0} is useless in option spec: \"$opt\"\n")
  841.       if defined($mi) && !$mi && !defined($ma) && !defined($cm);
  842.  
  843.     $type = 'i' if $type eq 'n';
  844.     $dest ||= '$';
  845.     $dest = $dest eq '@' ? CTL_DEST_ARRAY
  846.       : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
  847.     # Default minargs to 1/0 depending on mand status.
  848.     $mi = $mand eq '=' ? 1 : 0 unless defined $mi;
  849.     # Adjust mand status according to minargs.
  850.     $mand = $mi ? '=' : ':';
  851.     # Adjust maxargs.
  852.     $ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
  853.     return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
  854.       if defined($ma) && !$ma;
  855.     return (undef, "Max less than min in option spec: \"$opt\"\n")
  856.       if defined($ma) && $ma < $mi;
  857.  
  858.     # Fields are hard-wired here.
  859.     $entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
  860.     }
  861.  
  862.     # Process all names. First is canonical, the rest are aliases.
  863.     my $dups = '';
  864.     foreach ( @names ) {
  865.  
  866.     $_ = lc ($_)
  867.       if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
  868.  
  869.     if ( exists $opctl->{$_} ) {
  870.         $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
  871.     }
  872.  
  873.     if ( $spec eq '!' ) {
  874.         $opctl->{"no$_"} = $entry;
  875.         $opctl->{"no-$_"} = $entry;
  876.         $opctl->{$_} = [@$entry];
  877.         $opctl->{$_}->[CTL_TYPE] = '';
  878.     }
  879.     else {
  880.         $opctl->{$_} = $entry;
  881.     }
  882.     }
  883.  
  884.     if ( $dups && $^W ) {
  885.     foreach ( split(/\n+/, $dups) ) {
  886.         warn($_."\n");
  887.     }
  888.     }
  889.     ($names[0], $orig);
  890. }
  891.  
  892. # Option lookup.
  893. sub FindOption ($$$$$) {
  894.  
  895.     # returns (1, $opt, $ctl, $arg, $key) if okay,
  896.     # returns (1, undef) if option in error,
  897.     # returns (0) otherwise.
  898.  
  899.     my ($argv, $prefix, $argend, $opt, $opctl) = @_;
  900.  
  901.     print STDERR ("=> find \"$opt\"\n") if $debug;
  902.  
  903.     return (0) unless $opt =~ /^$prefix(.*)$/s;
  904.     return (0) if $opt eq "-" && !defined $opctl->{''};
  905.  
  906.     $opt = $+;
  907.     my $starter = $1;
  908.  
  909.     print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
  910.  
  911.     my $optarg;            # value supplied with --opt=value
  912.     my $rest;            # remainder from unbundling
  913.  
  914.     # If it is a long option, it may include the value.
  915.     # With getopt_compat, only if not bundling.
  916.     if ( ($starter=~/^$longprefix$/
  917.           || ($getopt_compat && ($bundling == 0 || $bundling == 2)))
  918.       && $opt =~ /^([^=]+)=(.*)$/s ) {
  919.     $opt = $1;
  920.     $optarg = $2;
  921.     print STDERR ("=> option \"", $opt,
  922.               "\", optarg = \"$optarg\"\n") if $debug;
  923.     }
  924.  
  925.     #### Look it up ###
  926.  
  927.     my $tryopt = $opt;        # option to try
  928.  
  929.     if ( $bundling && $starter eq '-' ) {
  930.  
  931.     # To try overrides, obey case ignore.
  932.     $tryopt = $ignorecase ? lc($opt) : $opt;
  933.  
  934.     # If bundling == 2, long options can override bundles.
  935.     if ( $bundling == 2 && length($tryopt) > 1
  936.          && defined ($opctl->{$tryopt}) ) {
  937.         print STDERR ("=> $starter$tryopt overrides unbundling\n")
  938.           if $debug;
  939.     }
  940.     else {
  941.         $tryopt = $opt;
  942.         # Unbundle single letter option.
  943.         $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
  944.         $tryopt = substr ($tryopt, 0, 1);
  945.         $tryopt = lc ($tryopt) if $ignorecase > 1;
  946.         print STDERR ("=> $starter$tryopt unbundled from ",
  947.               "$starter$tryopt$rest\n") if $debug;
  948.         $rest = undef unless $rest ne '';
  949.     }
  950.     }
  951.  
  952.     # Try auto-abbreviation.
  953.     elsif ( $autoabbrev ) {
  954.     # Sort the possible long option names.
  955.     my @names = sort(keys (%$opctl));
  956.     # Downcase if allowed.
  957.     $opt = lc ($opt) if $ignorecase;
  958.     $tryopt = $opt;
  959.     # Turn option name into pattern.
  960.     my $pat = quotemeta ($opt);
  961.     # Look up in option names.
  962.     my @hits = grep (/^$pat/, @names);
  963.     print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
  964.               "out of ", scalar(@names), "\n") if $debug;
  965.  
  966.     # Check for ambiguous results.
  967.     unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
  968.         # See if all matches are for the same option.
  969.         my %hit;
  970.         foreach ( @hits ) {
  971.         my $hit = $_;
  972.         $hit = $opctl->{$hit}->[CTL_CNAME]
  973.           if defined $opctl->{$hit}->[CTL_CNAME];
  974.         $hit{$hit} = 1;
  975.         }
  976.         # Remove auto-supplied options (version, help).
  977.         if ( keys(%hit) == 2 ) {
  978.         if ( $auto_version && exists($hit{version}) ) {
  979.             delete $hit{version};
  980.         }
  981.         elsif ( $auto_help && exists($hit{help}) ) {
  982.             delete $hit{help};
  983.         }
  984.         }
  985.         # Now see if it really is ambiguous.
  986.         unless ( keys(%hit) == 1 ) {
  987.         return (0) if $passthrough;
  988.         warn ("Option ", $opt, " is ambiguous (",
  989.               join(", ", @hits), ")\n");
  990.         $error++;
  991.         return (1, undef);
  992.         }
  993.         @hits = keys(%hit);
  994.     }
  995.  
  996.     # Complete the option name, if appropriate.
  997.     if ( @hits == 1 && $hits[0] ne $opt ) {
  998.         $tryopt = $hits[0];
  999.         $tryopt = lc ($tryopt) if $ignorecase;
  1000.         print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
  1001.         if $debug;
  1002.     }
  1003.     }
  1004.  
  1005.     # Map to all lowercase if ignoring case.
  1006.     elsif ( $ignorecase ) {
  1007.     $tryopt = lc ($opt);
  1008.     }
  1009.  
  1010.     # Check validity by fetching the info.
  1011.     my $ctl = $opctl->{$tryopt};
  1012.     unless  ( defined $ctl ) {
  1013.     return (0) if $passthrough;
  1014.     # Pretend one char when bundling.
  1015.     if ( $bundling == 1 && length($starter) == 1 ) {
  1016.         $opt = substr($opt,0,1);
  1017.             unshift (@$argv, $starter.$rest) if defined $rest;
  1018.     }
  1019.     warn ("Unknown option: ", $opt, "\n");
  1020.     $error++;
  1021.     return (1, undef);
  1022.     }
  1023.     # Apparently valid.
  1024.     $opt = $tryopt;
  1025.     print STDERR ("=> found ", OptCtl($ctl),
  1026.           " for \"", $opt, "\"\n") if $debug;
  1027.  
  1028.     #### Determine argument status ####
  1029.  
  1030.     # If it is an option w/o argument, we're almost finished with it.
  1031.     my $type = $ctl->[CTL_TYPE];
  1032.     my $arg;
  1033.  
  1034.     if ( $type eq '' || $type eq '!' || $type eq '+' ) {
  1035.     if ( defined $optarg ) {
  1036.         return (0) if $passthrough;
  1037.         warn ("Option ", $opt, " does not take an argument\n");
  1038.         $error++;
  1039.         undef $opt;
  1040.     }
  1041.     elsif ( $type eq '' || $type eq '+' ) {
  1042.         # Supply explicit value.
  1043.         $arg = 1;
  1044.     }
  1045.     else {
  1046.         $opt =~ s/^no-?//i;    # strip NO prefix
  1047.         $arg = 0;        # supply explicit value
  1048.     }
  1049.     unshift (@$argv, $starter.$rest) if defined $rest;
  1050.     return (1, $opt, $ctl, $arg);
  1051.     }
  1052.  
  1053.     # Get mandatory status and type info.
  1054.     my $mand = $ctl->[CTL_AMIN];
  1055.  
  1056.     # Check if there is an option argument available.
  1057.     if ( $gnu_compat && defined $optarg && $optarg eq '' ) {
  1058.     return (1, $opt, $ctl, $type eq 's' ? '' : 0) ;#unless $mand;
  1059.     $optarg = 0 unless $type eq 's';
  1060.     }
  1061.  
  1062.     # Check if there is an option argument available.
  1063.     if ( defined $optarg
  1064.      ? ($optarg eq '')
  1065.      : !(defined $rest || @$argv > 0) ) {
  1066.     # Complain if this option needs an argument.
  1067. #    if ( $mand && !($type eq 's' ? defined($optarg) : 0) ) {
  1068.     if ( $mand ) {
  1069.         return (0) if $passthrough;
  1070.         warn ("Option ", $opt, " requires an argument\n");
  1071.         $error++;
  1072.         return (1, undef);
  1073.     }
  1074.     if ( $type eq 'I' ) {
  1075.         # Fake incremental type.
  1076.         my @c = @$ctl;
  1077.         $c[CTL_TYPE] = '+';
  1078.         return (1, $opt, \@c, 1);
  1079.     }
  1080.     return (1, $opt, $ctl,
  1081.         defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
  1082.         $type eq 's' ? '' : 0);
  1083.     }
  1084.  
  1085.     # Get (possibly optional) argument.
  1086.     $arg = (defined $rest ? $rest
  1087.         : (defined $optarg ? $optarg : shift (@$argv)));
  1088.  
  1089.     # Get key if this is a "name=value" pair for a hash option.
  1090.     my $key;
  1091.     if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
  1092.     ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
  1093.       : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
  1094.          ($mand ? undef : ($type eq 's' ? "" : 1)));
  1095.     if (! defined $arg) {
  1096.         warn ("Option $opt, key \"$key\", requires a value\n");
  1097.         $error++;
  1098.         # Push back.
  1099.         unshift (@$argv, $starter.$rest) if defined $rest;
  1100.         return (1, undef);
  1101.     }
  1102.     }
  1103.  
  1104.     #### Check if the argument is valid for this option ####
  1105.  
  1106.     my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
  1107.  
  1108.     if ( $type eq 's' ) {    # string
  1109.     # A mandatory string takes anything.
  1110.     return (1, $opt, $ctl, $arg, $key) if $mand;
  1111.  
  1112.     # Same for optional string as a hash value
  1113.     return (1, $opt, $ctl, $arg, $key)
  1114.       if $ctl->[CTL_DEST] == CTL_DEST_HASH;
  1115.  
  1116.     # An optional string takes almost anything.
  1117.     return (1, $opt, $ctl, $arg, $key)
  1118.       if defined $optarg || defined $rest;
  1119.     return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
  1120.  
  1121.     # Check for option or option list terminator.
  1122.     if ($arg eq $argend ||
  1123.         $arg =~ /^$prefix.+/) {
  1124.         # Push back.
  1125.         unshift (@$argv, $arg);
  1126.         # Supply empty value.
  1127.         $arg = '';
  1128.     }
  1129.     }
  1130.  
  1131.     elsif ( $type eq 'i'    # numeric/integer
  1132.             || $type eq 'I'    # numeric/integer w/ incr default
  1133.         || $type eq 'o' ) { # dec/oct/hex/bin value
  1134.  
  1135.     my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
  1136.  
  1137.     if ( $bundling && defined $rest
  1138.          && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
  1139.         ($key, $arg, $rest) = ($1, $2, $+);
  1140.         chop($key) if $key;
  1141.         $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
  1142.         unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
  1143.     }
  1144.     elsif ( $arg =~ /^$o_valid$/si ) {
  1145.         $arg =~ tr/_//d;
  1146.         $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
  1147.     }
  1148.     else {
  1149.         if ( defined $optarg || $mand ) {
  1150.         if ( $passthrough ) {
  1151.             unshift (@$argv, defined $rest ? $starter.$rest : $arg)
  1152.               unless defined $optarg;
  1153.             return (0);
  1154.         }
  1155.         warn ("Value \"", $arg, "\" invalid for option ",
  1156.               $opt, " (",
  1157.               $type eq 'o' ? "extended " : '',
  1158.               "number expected)\n");
  1159.         $error++;
  1160.         # Push back.
  1161.         unshift (@$argv, $starter.$rest) if defined $rest;
  1162.         return (1, undef);
  1163.         }
  1164.         else {
  1165.         # Push back.
  1166.         unshift (@$argv, defined $rest ? $starter.$rest : $arg);
  1167.         if ( $type eq 'I' ) {
  1168.             # Fake incremental type.
  1169.             my @c = @$ctl;
  1170.             $c[CTL_TYPE] = '+';
  1171.             return (1, $opt, \@c, 1);
  1172.         }
  1173.         # Supply default value.
  1174.         $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
  1175.         }
  1176.     }
  1177.     }
  1178.  
  1179.     elsif ( $type eq 'f' ) { # real number, int is also ok
  1180.     # We require at least one digit before a point or 'e',
  1181.     # and at least one digit following the point and 'e'.
  1182.     # [-]NN[.NN][eNN]
  1183.     my $o_valid = PAT_FLOAT;
  1184.     if ( $bundling && defined $rest &&
  1185.          $rest =~ /^($key_valid)($o_valid)(.*)$/s ) {
  1186.         $arg =~ tr/_//d;
  1187.         ($key, $arg, $rest) = ($1, $2, $+);
  1188.         chop($key) if $key;
  1189.         unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
  1190.     }
  1191.     elsif ( $arg =~ /^$o_valid$/ ) {
  1192.         $arg =~ tr/_//d;
  1193.     }
  1194.     else {
  1195.         if ( defined $optarg || $mand ) {
  1196.         if ( $passthrough ) {
  1197.             unshift (@$argv, defined $rest ? $starter.$rest : $arg)
  1198.               unless defined $optarg;
  1199.             return (0);
  1200.         }
  1201.         warn ("Value \"", $arg, "\" invalid for option ",
  1202.               $opt, " (real number expected)\n");
  1203.         $error++;
  1204.         # Push back.
  1205.         unshift (@$argv, $starter.$rest) if defined $rest;
  1206.         return (1, undef);
  1207.         }
  1208.         else {
  1209.         # Push back.
  1210.         unshift (@$argv, defined $rest ? $starter.$rest : $arg);
  1211.         # Supply default value.
  1212.         $arg = 0.0;
  1213.         }
  1214.     }
  1215.     }
  1216.     else {
  1217.     die("Getopt::Long internal error (Can't happen)\n");
  1218.     }
  1219.     return (1, $opt, $ctl, $arg, $key);
  1220. }
  1221.  
  1222. sub ValidValue ($$$$$) {
  1223.     my ($ctl, $arg, $mand, $argend, $prefix) = @_;
  1224.  
  1225.     if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
  1226.     return 0 unless $arg =~ /[^=]+=(.*)/;
  1227.     $arg = $1;
  1228.     }
  1229.  
  1230.     my $type = $ctl->[CTL_TYPE];
  1231.  
  1232.     if ( $type eq 's' ) {    # string
  1233.     # A mandatory string takes anything.
  1234.     return (1) if $mand;
  1235.  
  1236.     return (1) if $arg eq "-";
  1237.  
  1238.     # Check for option or option list terminator.
  1239.     return 0 if $arg eq $argend || $arg =~ /^$prefix.+/;
  1240.     return 1;
  1241.     }
  1242.  
  1243.     elsif ( $type eq 'i'    # numeric/integer
  1244.             || $type eq 'I'    # numeric/integer w/ incr default
  1245.         || $type eq 'o' ) { # dec/oct/hex/bin value
  1246.  
  1247.     my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
  1248.     return $arg =~ /^$o_valid$/si;
  1249.     }
  1250.  
  1251.     elsif ( $type eq 'f' ) { # real number, int is also ok
  1252.     # We require at least one digit before a point or 'e',
  1253.     # and at least one digit following the point and 'e'.
  1254.     # [-]NN[.NN][eNN]
  1255.     my $o_valid = PAT_FLOAT;
  1256.     return $arg =~ /^$o_valid$/;
  1257.     }
  1258.     die("ValidValue: Cannot happen\n");
  1259. }
  1260.  
  1261. # Getopt::Long Configuration.
  1262. sub Configure (@) {
  1263.     my (@options) = @_;
  1264.  
  1265.     my $prevconfig =
  1266.       [ $error, $debug, $major_version, $minor_version,
  1267.     $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
  1268.     $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
  1269.     $longprefix ];
  1270.  
  1271.     if ( ref($options[0]) eq 'ARRAY' ) {
  1272.     ( $error, $debug, $major_version, $minor_version,
  1273.       $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
  1274.       $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
  1275.       $longprefix ) = @{shift(@options)};
  1276.     }
  1277.  
  1278.     my $opt;
  1279.     foreach $opt ( @options ) {
  1280.     my $try = lc ($opt);
  1281.     my $action = 1;
  1282.     if ( $try =~ /^no_?(.*)$/s ) {
  1283.         $action = 0;
  1284.         $try = $+;
  1285.     }
  1286.     if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
  1287.         ConfigDefaults ();
  1288.     }
  1289.     elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
  1290.         local $ENV{POSIXLY_CORRECT};
  1291.         $ENV{POSIXLY_CORRECT} = 1 if $action;
  1292.         ConfigDefaults ();
  1293.     }
  1294.     elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
  1295.         $autoabbrev = $action;
  1296.     }
  1297.     elsif ( $try eq 'getopt_compat' ) {
  1298.         $getopt_compat = $action;
  1299.             $genprefix = $action ? "(--|-|\\+)" : "(--|-)";
  1300.     }
  1301.     elsif ( $try eq 'gnu_getopt' ) {
  1302.         if ( $action ) {
  1303.         $gnu_compat = 1;
  1304.         $bundling = 1;
  1305.         $getopt_compat = 0;
  1306.                 $genprefix = "(--|-)";
  1307.         $order = $PERMUTE;
  1308.         }
  1309.     }
  1310.     elsif ( $try eq 'gnu_compat' ) {
  1311.         $gnu_compat = $action;
  1312.     }
  1313.     elsif ( $try =~ /^(auto_?)?version$/ ) {
  1314.         $auto_version = $action;
  1315.     }
  1316.     elsif ( $try =~ /^(auto_?)?help$/ ) {
  1317.         $auto_help = $action;
  1318.     }
  1319.     elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
  1320.         $ignorecase = $action;
  1321.     }
  1322.     elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) {
  1323.         $ignorecase = $action ? 2 : 0;
  1324.     }
  1325.     elsif ( $try eq 'bundling' ) {
  1326.         $bundling = $action;
  1327.     }
  1328.     elsif ( $try eq 'bundling_override' ) {
  1329.         $bundling = $action ? 2 : 0;
  1330.     }
  1331.     elsif ( $try eq 'require_order' ) {
  1332.         $order = $action ? $REQUIRE_ORDER : $PERMUTE;
  1333.     }
  1334.     elsif ( $try eq 'permute' ) {
  1335.         $order = $action ? $PERMUTE : $REQUIRE_ORDER;
  1336.     }
  1337.     elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
  1338.         $passthrough = $action;
  1339.     }
  1340.     elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
  1341.         $genprefix = $1;
  1342.         # Turn into regexp. Needs to be parenthesized!
  1343.         $genprefix = "(" . quotemeta($genprefix) . ")";
  1344.         eval { '' =~ /$genprefix/; };
  1345.         die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
  1346.     }
  1347.     elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
  1348.         $genprefix = $1;
  1349.         # Parenthesize if needed.
  1350.         $genprefix = "(" . $genprefix . ")"
  1351.           unless $genprefix =~ /^\(.*\)$/;
  1352.         eval { '' =~ m"$genprefix"; };
  1353.         die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
  1354.     }
  1355.     elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) {
  1356.         $longprefix = $1;
  1357.         # Parenthesize if needed.
  1358.         $longprefix = "(" . $longprefix . ")"
  1359.           unless $longprefix =~ /^\(.*\)$/;
  1360.         eval { '' =~ m"$longprefix"; };
  1361.         die("Getopt::Long: invalid long prefix pattern \"$longprefix\"") if $@;
  1362.     }
  1363.     elsif ( $try eq 'debug' ) {
  1364.         $debug = $action;
  1365.     }
  1366.     else {
  1367.         die("Getopt::Long: unknown config parameter \"$opt\"")
  1368.     }
  1369.     }
  1370.     $prevconfig;
  1371. }
  1372.  
  1373. # Deprecated name.
  1374. sub config (@) {
  1375.     Configure (@_);
  1376. }
  1377.  
  1378. # Issue a standard message for --version.
  1379. #
  1380. # The arguments are mostly the same as for Pod::Usage::pod2usage:
  1381. #
  1382. #  - a number (exit value)
  1383. #  - a string (lead in message)
  1384. #  - a hash with options. See Pod::Usage for details.
  1385. #
  1386. sub VersionMessage(@) {
  1387.     # Massage args.
  1388.     my $pa = setup_pa_args("version", @_);
  1389.  
  1390.     my $v = $main::VERSION;
  1391.     my $fh = $pa->{-output} ||
  1392.       ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR;
  1393.  
  1394.     print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
  1395.            $0, defined $v ? " version $v" : (),
  1396.            "\n",
  1397.            "(", __PACKAGE__, "::", "GetOptions",
  1398.            " version ",
  1399.            defined($Getopt::Long::VERSION_STRING)
  1400.              ? $Getopt::Long::VERSION_STRING : $VERSION, ";",
  1401.            " Perl version ",
  1402.            $] >= 5.006 ? sprintf("%vd", $^V) : $],
  1403.            ")\n");
  1404.     exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT";
  1405. }
  1406.  
  1407. # Issue a standard message for --help.
  1408. #
  1409. # The arguments are the same as for Pod::Usage::pod2usage:
  1410. #
  1411. #  - a number (exit value)
  1412. #  - a string (lead in message)
  1413. #  - a hash with options. See Pod::Usage for details.
  1414. #
  1415. sub HelpMessage(@) {
  1416.     eval {
  1417.     require Pod::Usage;
  1418.     import Pod::Usage;
  1419.     1;
  1420.     } || die("Cannot provide help: cannot load Pod::Usage\n");
  1421.  
  1422.     # Note that pod2usage will issue a warning if -exitval => NOEXIT.
  1423.     pod2usage(setup_pa_args("help", @_));
  1424.  
  1425. }
  1426.  
  1427. # Helper routine to set up a normalized hash ref to be used as
  1428. # argument to pod2usage.
  1429. sub setup_pa_args($@) {
  1430.     my $tag = shift;        # who's calling
  1431.  
  1432.     # If called by direct binding to an option, it will get the option
  1433.     # name and value as arguments. Remove these, if so.
  1434.     @_ = () if @_ == 2 && $_[0] eq $tag;
  1435.  
  1436.     my $pa;
  1437.     if ( @_ > 1 ) {
  1438.     $pa = { @_ };
  1439.     }
  1440.     else {
  1441.     $pa = shift || {};
  1442.     }
  1443.  
  1444.     # At this point, $pa can be a number (exit value), string
  1445.     # (message) or hash with options.
  1446.  
  1447.     if ( UNIVERSAL::isa($pa, 'HASH') ) {
  1448.     # Get rid of -msg vs. -message ambiguity.
  1449.     $pa->{-message} = $pa->{-msg};
  1450.     delete($pa->{-msg});
  1451.     }
  1452.     elsif ( $pa =~ /^-?\d+$/ ) {
  1453.     $pa = { -exitval => $pa };
  1454.     }
  1455.     else {
  1456.     $pa = { -message => $pa };
  1457.     }
  1458.  
  1459.     # These are _our_ defaults.
  1460.     $pa->{-verbose} = 0 unless exists($pa->{-verbose});
  1461.     $pa->{-exitval} = 0 unless exists($pa->{-exitval});
  1462.     $pa;
  1463. }
  1464.  
  1465. # Sneak way to know what version the user requested.
  1466. sub VERSION {
  1467.     $requested_version = $_[1];
  1468.     shift->SUPER::VERSION(@_);
  1469. }
  1470.  
  1471. package Getopt::Long::CallBack;
  1472.  
  1473. sub new {
  1474.     my ($pkg, %atts) = @_;
  1475.     bless { %atts }, $pkg;
  1476. }
  1477.  
  1478. sub name {
  1479.     my $self = shift;
  1480.     ''.$self->{name};
  1481. }
  1482.  
  1483. use overload
  1484.   # Treat this object as an oridinary string for legacy API.
  1485.   '""'       => \&name,
  1486.   fallback => 1;
  1487.  
  1488. 1;
  1489.  
  1490. ################ Documentation ################
  1491.  
  1492.