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