home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.6.1.638-MSWin32-x86.msi / _29c99a3e163fb007623530ee50f770d0 < prev    next >
Encoding:
Text File  |  2004-04-13  |  12.3 KB  |  449 lines
  1. # NOTE: Derived from ../LIB\Getopt\Long.pm.
  2. # Changes made here will be lost when autosplit is run again.
  3. # See AutoSplit.pm.
  4. package Getopt::Long;
  5.  
  6. #line 216 "../LIB\Getopt\Long.pm (autosplit into ..\lib\auto\Getopt\Long\GetOptions.al)"
  7. ################ AutoLoading subroutines ################
  8.  
  9. # RCS Status      : $Id: GetoptLongAl.pl,v 2.30 2001-01-31 10:21:11+01 jv Exp $
  10. # Author          : Johan Vromans
  11. # Created On      : Fri Mar 27 11:50:30 1998
  12. # Last Modified By: Johan Vromans
  13. # Last Modified On: Tue Dec 26 18:01:16 2000
  14. # Update Count    : 98
  15. # Status          : Released
  16.  
  17. sub GetOptions {
  18.  
  19.     my @optionlist = @_;    # local copy of the option descriptions
  20.     my $argend = '--';        # option list terminator
  21.     my %opctl = ();        # table of arg.specs (long and abbrevs)
  22.     my %bopctl = ();        # table of arg.specs (bundles)
  23.     my $pkg = $caller || (caller)[0];    # current context
  24.                 # Needed if linkage is omitted.
  25.     my %aliases= ();        # alias table
  26.     my @ret = ();        # accum for non-options
  27.     my %linkage;        # linkage
  28.     my $userlinkage;        # user supplied HASH
  29.     my $opt;            # current option
  30.     my $genprefix = $genprefix;    # so we can call the same module many times
  31.     my @opctl;            # the possible long option names
  32.  
  33.     $error = '';
  34.  
  35.     print STDERR ("GetOpt::Long $Getopt::Long::VERSION ",
  36.           "called from package \"$pkg\".",
  37.           "\n  ",
  38.           'GetOptionsAl $Revision: 2.30 $ ',
  39.           "\n  ",
  40.           "ARGV: (@ARGV)",
  41.           "\n  ",
  42.           "autoabbrev=$autoabbrev,".
  43.           "bundling=$bundling,",
  44.           "getopt_compat=$getopt_compat,",
  45.           "gnu_compat=$gnu_compat,",
  46.           "order=$order,",
  47.           "\n  ",
  48.           "ignorecase=$ignorecase,",
  49.           "passthrough=$passthrough,",
  50.           "genprefix=\"$genprefix\".",
  51.           "\n")
  52.     if $debug;
  53.  
  54.     # Check for ref HASH as first argument.
  55.     # First argument may be an object. It's OK to use this as long
  56.     # as it is really a hash underneath.
  57.     $userlinkage = undef;
  58.     if ( ref($optionlist[0]) and
  59.      "$optionlist[0]" =~ /^(?:.*\=)?HASH\([^\(]*\)$/ ) {
  60.     $userlinkage = shift (@optionlist);
  61.     print STDERR ("=> user linkage: $userlinkage\n") if $debug;
  62.     }
  63.  
  64.     # See if the first element of the optionlist contains option
  65.     # starter characters.
  66.     # Be careful not to interpret '<>' as option starters.
  67.     if ( $optionlist[0] =~ /^\W+$/
  68.      && !($optionlist[0] eq '<>'
  69.           && @optionlist > 0
  70.           && ref($optionlist[1])) ) {
  71.     $genprefix = shift (@optionlist);
  72.     # Turn into regexp. Needs to be parenthesized!
  73.     $genprefix =~ s/(\W)/\\$1/g;
  74.     $genprefix = "([" . $genprefix . "])";
  75.     }
  76.  
  77.     # Verify correctness of optionlist.
  78.     %opctl = ();
  79.     %bopctl = ();
  80.     while ( @optionlist > 0 ) {
  81.     my $opt = shift (@optionlist);
  82.  
  83.     # Strip leading prefix so people can specify "--foo=i" if they like.
  84.     $opt = $+ if $opt =~ /^$genprefix+(.*)$/s;
  85.  
  86.     if ( $opt eq '<>' ) {
  87.         if ( (defined $userlinkage)
  88.         && !(@optionlist > 0 && ref($optionlist[0]))
  89.         && (exists $userlinkage->{$opt})
  90.         && ref($userlinkage->{$opt}) ) {
  91.         unshift (@optionlist, $userlinkage->{$opt});
  92.         }
  93.         unless ( @optionlist > 0
  94.             && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
  95.         $error .= "Option spec <> requires a reference to a subroutine\n";
  96.         next;
  97.         }
  98.         $linkage{'<>'} = shift (@optionlist);
  99.         next;
  100.     }
  101.  
  102.     # Match option spec. Allow '?' as an alias only.
  103.     if ( $opt !~ /^((\w+[-\w]*)(\|(\?|\w[-\w]*)?)*)?([!~+]|[=:][infse][@%]?)?$/ ) {
  104.         $error .= "Error in option spec: \"$opt\"\n";
  105.         next;
  106.     }
  107.     my ($o, $c, $a) = ($1, $5);
  108.     $c = '' unless defined $c;
  109.  
  110.     # $linko keeps track of the primary name the user specified.
  111.     # This name will be used for the internal or external linkage.
  112.     # In other words, if the user specifies "FoO|BaR", it will
  113.     # match any case combinations of 'foo' and 'bar', but if a global
  114.     # variable needs to be set, it will be $opt_FoO in the exact case
  115.     # as specified.
  116.     my $linko;
  117.  
  118.     if ( ! defined $o ) {
  119.         # empty -> '-' option
  120.         $linko = $o = '';
  121.         $opctl{''} = $c;
  122.         $bopctl{''} = $c if $bundling;
  123.     }
  124.     else {
  125.         # Handle alias names
  126.         my @o =  split (/\|/, $o);
  127.         $linko = $o = $o[0];
  128.         # Force an alias if the option name is not locase.
  129.         $a = $o unless $o eq lc($o);
  130.         $o = lc ($o)
  131.         if $ignorecase > 1
  132.             || ($ignorecase
  133.             && ($bundling ? length($o) > 1  : 1));
  134.  
  135.         foreach ( @o ) {
  136.         if ( $bundling && length($_) == 1 ) {
  137.             $_ = lc ($_) if $ignorecase > 1;
  138.             if ( $c eq '!' ) {
  139.             $opctl{"no$_"} = $c;
  140.             warn ("Ignoring '!' modifier for short option $_\n");
  141.             $opctl{$_} = $bopctl{$_} = '';
  142.             }
  143.             else {
  144.             $opctl{$_} = $bopctl{$_} = $c;
  145.             }
  146.         }
  147.         else {
  148.             $_ = lc ($_) if $ignorecase;
  149.             if ( $c eq '!' ) {
  150.             $opctl{"no$_"} = $c;
  151.             $opctl{$_} = ''
  152.             }
  153.             else {
  154.             $opctl{$_} = $c;
  155.             }
  156.         }
  157.         if ( defined $a ) {
  158.             # Note alias.
  159.             $aliases{$_} = $a;
  160.         }
  161.         else {
  162.             # Set primary name.
  163.             $a = $_;
  164.         }
  165.         }
  166.     }
  167.  
  168.     # If no linkage is supplied in the @optionlist, copy it from
  169.     # the userlinkage if available.
  170.     if ( defined $userlinkage ) {
  171.         unless ( @optionlist > 0 && ref($optionlist[0]) ) {
  172.         if ( exists $userlinkage->{$linko} &&
  173.              ref($userlinkage->{$linko}) ) {
  174.             print STDERR ("=> found userlinkage for \"$linko\": ",
  175.                   "$userlinkage->{$linko}\n")
  176.             if $debug;
  177.             unshift (@optionlist, $userlinkage->{$linko});
  178.         }
  179.         else {
  180.             # Do nothing. Being undefined will be handled later.
  181.             next;
  182.         }
  183.         }
  184.     }
  185.  
  186.     # Copy the linkage. If omitted, link to global variable.
  187.     if ( @optionlist > 0 && ref($optionlist[0]) ) {
  188.         print STDERR ("=> link \"$linko\" to $optionlist[0]\n")
  189.         if $debug;
  190.         if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) {
  191.         $linkage{$linko} = shift (@optionlist);
  192.         }
  193.         elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) {
  194.         $linkage{$linko} = shift (@optionlist);
  195.         $opctl{$o} .= '@'
  196.           if $opctl{$o} ne '' and $opctl{$o} !~ /\@$/;
  197.         $bopctl{$o} .= '@'
  198.           if $bundling and defined $bopctl{$o} and
  199.             $bopctl{$o} ne '' and $bopctl{$o} !~ /\@$/;
  200.         }
  201.         elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) {
  202.         $linkage{$linko} = shift (@optionlist);
  203.         $opctl{$o} .= '%'
  204.           if $opctl{$o} ne '' and $opctl{$o} !~ /\%$/;
  205.         $bopctl{$o} .= '%'
  206.           if $bundling and defined $bopctl{$o} and
  207.             $bopctl{$o} ne '' and $bopctl{$o} !~ /\%$/;
  208.         }
  209.         else {
  210.         $error .= "Invalid option linkage for \"$opt\"\n";
  211.         }
  212.     }
  213.     else {
  214.         # Link to global $opt_XXX variable.
  215.         # Make sure a valid perl identifier results.
  216.         my $ov = $linko;
  217.         $ov =~ s/\W/_/g;
  218.         if ( $c =~ /@/ ) {
  219.         print STDERR ("=> link \"$linko\" to \@$pkg","::opt_$ov\n")
  220.             if $debug;
  221.         eval ("\$linkage{\$linko} = \\\@".$pkg."::opt_$ov;");
  222.         }
  223.         elsif ( $c =~ /%/ ) {
  224.         print STDERR ("=> link \"$linko\" to \%$pkg","::opt_$ov\n")
  225.             if $debug;
  226.         eval ("\$linkage{\$linko} = \\\%".$pkg."::opt_$ov;");
  227.         }
  228.         else {
  229.         print STDERR ("=> link \"$linko\" to \$$pkg","::opt_$ov\n")
  230.             if $debug;
  231.         eval ("\$linkage{\$linko} = \\\$".$pkg."::opt_$ov;");
  232.         }
  233.     }
  234.     }
  235.  
  236.     # Bail out if errors found.
  237.     die ($error) if $error;
  238.     $error = 0;
  239.  
  240.     # Sort the possible long option names.
  241.     @opctl = sort(keys (%opctl)) if $autoabbrev;
  242.  
  243.     # Show the options tables if debugging.
  244.     if ( $debug ) {
  245.     my ($arrow, $k, $v);
  246.     $arrow = "=> ";
  247.     while ( ($k,$v) = each(%opctl) ) {
  248.         print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
  249.         $arrow = "   ";
  250.     }
  251.     $arrow = "=> ";
  252.     while ( ($k,$v) = each(%bopctl) ) {
  253.         print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n");
  254.         $arrow = "   ";
  255.     }
  256.     }
  257.  
  258.     # Process argument list
  259.     my $goon = 1;
  260.     while ( $goon && @ARGV > 0 ) {
  261.  
  262.     #### Get next argument ####
  263.  
  264.     $opt = shift (@ARGV);
  265.     print STDERR ("=> option \"", $opt, "\"\n") if $debug;
  266.  
  267.     #### Determine what we have ####
  268.  
  269.     # Double dash is option list terminator.
  270.     if ( $opt eq $argend ) {
  271.         # Finish. Push back accumulated arguments and return.
  272.         unshift (@ARGV, @ret)
  273.         if $order == $PERMUTE;
  274.         return ($error == 0);
  275.     }
  276.  
  277.     my $tryopt = $opt;
  278.     my $found;        # success status
  279.     my $dsttype;        # destination type ('@' or '%')
  280.     my $incr;        # destination increment
  281.     my $key;        # key (if hash type)
  282.     my $arg;        # option argument
  283.  
  284.     ($found, $opt, $arg, $dsttype, $incr, $key) =
  285.       FindOption ($genprefix, $argend, $opt,
  286.               \%opctl, \%bopctl, \@opctl, \%aliases);
  287.  
  288.     if ( $found ) {
  289.  
  290.         # FindOption undefines $opt in case of errors.
  291.         next unless defined $opt;
  292.  
  293.         if ( defined $arg ) {
  294.         if ( defined $aliases{$opt} ) {
  295.             print STDERR ("=> alias \"$opt\" -> \"$aliases{$opt}\"\n")
  296.               if $debug;
  297.             $opt = $aliases{$opt};
  298.         }
  299.  
  300.         if ( defined $linkage{$opt} ) {
  301.             print STDERR ("=> ref(\$L{$opt}) -> ",
  302.                   ref($linkage{$opt}), "\n") if $debug;
  303.  
  304.             if ( ref($linkage{$opt}) eq 'SCALAR' ) {
  305.             if ( $incr ) {
  306.                 print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
  307.                   if $debug;
  308.                 if ( defined ${$linkage{$opt}} ) {
  309.                     ${$linkage{$opt}} += $arg;
  310.                 }
  311.                     else {
  312.                     ${$linkage{$opt}} = $arg;
  313.                 }
  314.             }
  315.             else {
  316.                 print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
  317.                   if $debug;
  318.                 ${$linkage{$opt}} = $arg;
  319.                 }
  320.             }
  321.             elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
  322.             print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
  323.                 if $debug;
  324.             push (@{$linkage{$opt}}, $arg);
  325.             }
  326.             elsif ( ref($linkage{$opt}) eq 'HASH' ) {
  327.             print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
  328.                 if $debug;
  329.             $linkage{$opt}->{$key} = $arg;
  330.             }
  331.             elsif ( ref($linkage{$opt}) eq 'CODE' ) {
  332.             print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n")
  333.                 if $debug;
  334.             local ($@);
  335.             eval {
  336.                 &{$linkage{$opt}}($opt, $arg);
  337.             };
  338.             print STDERR ("=> die($@)\n") if $debug && $@ ne '';
  339.             if ( $@ =~ /^!/ ) {
  340.                 if ( $@ =~ /^!FINISH\b/ ) {
  341.                 $goon = 0;
  342.                 }
  343.             }
  344.             elsif ( $@ ne '' ) {
  345.                 warn ($@);
  346.                 $error++;
  347.             }
  348.             }
  349.             else {
  350.             print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
  351.                       "\" in linkage\n");
  352.             Croak ("Getopt::Long -- internal error!\n");
  353.             }
  354.         }
  355.         # No entry in linkage means entry in userlinkage.
  356.         elsif ( $dsttype eq '@' ) {
  357.             if ( defined $userlinkage->{$opt} ) {
  358.             print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
  359.                 if $debug;
  360.             push (@{$userlinkage->{$opt}}, $arg);
  361.             }
  362.             else {
  363.             print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
  364.                 if $debug;
  365.             $userlinkage->{$opt} = [$arg];
  366.             }
  367.         }
  368.         elsif ( $dsttype eq '%' ) {
  369.             if ( defined $userlinkage->{$opt} ) {
  370.             print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
  371.                 if $debug;
  372.             $userlinkage->{$opt}->{$key} = $arg;
  373.             }
  374.             else {
  375.             print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
  376.                 if $debug;
  377.             $userlinkage->{$opt} = {$key => $arg};
  378.             }
  379.         }
  380.         else {
  381.             if ( $incr ) {
  382.             print STDERR ("=> \$L{$opt} += \"$arg\"\n")
  383.               if $debug;
  384.             if ( defined $userlinkage->{$opt} ) {
  385.                 $userlinkage->{$opt} += $arg;
  386.             }
  387.             else {
  388.                 $userlinkage->{$opt} = $arg;
  389.             }
  390.             }
  391.             else {
  392.             print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
  393.             $userlinkage->{$opt} = $arg;
  394.             }
  395.         }
  396.         }
  397.     }
  398.  
  399.     # Not an option. Save it if we $PERMUTE and don't have a <>.
  400.     elsif ( $order == $PERMUTE ) {
  401.         # Try non-options call-back.
  402.         my $cb;
  403.         if ( (defined ($cb = $linkage{'<>'})) ) {
  404.         local ($@);
  405.         eval {
  406.             &$cb ($tryopt);
  407.         };
  408.         print STDERR ("=> die($@)\n") if $debug && $@ ne '';
  409.         if ( $@ =~ /^!/ ) {
  410.             if ( $@ =~ /^!FINISH\b/ ) {
  411.             $goon = 0;
  412.             }
  413.         }
  414.         elsif ( $@ ne '' ) {
  415.             warn ($@);
  416.             $error++;
  417.         }
  418.         }
  419.         else {
  420.         print STDERR ("=> saving \"$tryopt\" ",
  421.                   "(not an option, may permute)\n") if $debug;
  422.         push (@ret, $tryopt);
  423.         }
  424.         next;
  425.     }
  426.  
  427.     # ...otherwise, terminate.
  428.     else {
  429.         # Push this one back and exit.
  430.         unshift (@ARGV, $tryopt);
  431.         return ($error == 0);
  432.     }
  433.  
  434.     }
  435.  
  436.     # Finish.
  437.     if ( $order == $PERMUTE ) {
  438.     #  Push back accumulated arguments
  439.     print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
  440.         if $debug && @ret > 0;
  441.     unshift (@ARGV, @ret) if @ret > 0;
  442.     }
  443.  
  444.     return ($error == 0);
  445. }
  446.  
  447. # end of Getopt::Long::GetOptions
  448. 1;
  449.