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