home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _f51d04eaa50d48ceb244dcf127f1654d < prev    next >
Text File  |  2000-03-24  |  8KB  |  266 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 535 "../LIB\Getopt\Long.pm (autosplit into ..\lib\auto/Getopt\Long/FindOption.al)"
  7. # Option lookup.
  8. sub FindOption ($$$$$$$) {
  9.  
  10.     # returns (1, $opt, $arg, $dsttype, $incr, $key) if okay,
  11.     # returns (0) otherwise.
  12.  
  13.     my ($prefix, $argend, $opt, $opctl, $bopctl, $names, $aliases) = @_;
  14.     my $key;            # hash key for a hash option
  15.     my $arg;
  16.  
  17.     print STDERR ("=> find \"$opt\", prefix=\"$prefix\"\n") if $debug;
  18.  
  19.     return (0) unless $opt =~ /^$prefix(.*)$/s;
  20.  
  21.     $opt = $+;
  22.     my ($starter) = $1;
  23.  
  24.     print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
  25.  
  26.     my $optarg = undef;    # value supplied with --opt=value
  27.     my $rest = undef;    # remainder from unbundling
  28.  
  29.     # If it is a long option, it may include the value.
  30.     if (($starter eq "--" || ($getopt_compat && !$bundling))
  31.     && $opt =~ /^([^=]+)=(.*)$/s ) {
  32.     $opt = $1;
  33.     $optarg = $2;
  34.     print STDERR ("=> option \"", $opt,
  35.               "\", optarg = \"$optarg\"\n") if $debug;
  36.     }
  37.  
  38.     #### Look it up ###
  39.  
  40.     my $tryopt = $opt;        # option to try
  41.     my $optbl = $opctl;        # table to look it up (long names)
  42.     my $type;
  43.     my $dsttype = '';
  44.     my $incr = 0;
  45.  
  46.     if ( $bundling && $starter eq '-' ) {
  47.     # Unbundle single letter option.
  48.     $rest = substr ($tryopt, 1);
  49.     $tryopt = substr ($tryopt, 0, 1);
  50.     $tryopt = lc ($tryopt) if $ignorecase > 1;
  51.     print STDERR ("=> $starter$tryopt unbundled from ",
  52.               "$starter$tryopt$rest\n") if $debug;
  53.     $rest = undef unless $rest ne '';
  54.     $optbl = $bopctl;    # look it up in the short names table
  55.  
  56.     # If bundling == 2, long options can override bundles.
  57.     if ( $bundling == 2 and
  58.          defined ($rest) and
  59.          defined ($type = $opctl->{$tryopt.$rest}) ) {
  60.         print STDERR ("=> $starter$tryopt rebundled to ",
  61.               "$starter$tryopt$rest\n") if $debug;
  62.         $tryopt .= $rest;
  63.         undef $rest;
  64.     }
  65.     }
  66.  
  67.     # Try auto-abbreviation.
  68.     elsif ( $autoabbrev ) {
  69.     # Downcase if allowed.
  70.     $tryopt = $opt = lc ($opt) if $ignorecase;
  71.     # Turn option name into pattern.
  72.     my $pat = quotemeta ($opt);
  73.     # Look up in option names.
  74.     my @hits = grep (/^$pat/, @{$names});
  75.     print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
  76.               "out of ", scalar(@{$names}), "\n") if $debug;
  77.  
  78.     # Check for ambiguous results.
  79.     unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
  80.         # See if all matches are for the same option.
  81.         my %hit;
  82.         foreach ( @hits ) {
  83.         $_ = $aliases->{$_} if defined $aliases->{$_};
  84.         $hit{$_} = 1;
  85.         }
  86.         # Now see if it really is ambiguous.
  87.         unless ( keys(%hit) == 1 ) {
  88.         return (0) if $passthrough;
  89.         warn ("Option ", $opt, " is ambiguous (",
  90.               join(", ", @hits), ")\n");
  91.         $error++;
  92.         undef $opt;
  93.         return (1, $opt,$arg,$dsttype,$incr,$key);
  94.         }
  95.         @hits = keys(%hit);
  96.     }
  97.  
  98.     # Complete the option name, if appropriate.
  99.     if ( @hits == 1 && $hits[0] ne $opt ) {
  100.         $tryopt = $hits[0];
  101.         $tryopt = lc ($tryopt) if $ignorecase;
  102.         print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
  103.         if $debug;
  104.     }
  105.     }
  106.  
  107.     # Map to all lowercase if ignoring case.
  108.     elsif ( $ignorecase ) {
  109.     $tryopt = lc ($opt);
  110.     }
  111.  
  112.     # Check validity by fetching the info.
  113.     $type = $optbl->{$tryopt} unless defined $type;
  114.     unless  ( defined $type ) {
  115.     return (0) if $passthrough;
  116.     warn ("Unknown option: ", $opt, "\n");
  117.     $error++;
  118.     return (1, $opt,$arg,$dsttype,$incr,$key);
  119.     }
  120.     # Apparently valid.
  121.     $opt = $tryopt;
  122.     print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
  123.  
  124.     #### Determine argument status ####
  125.  
  126.     # If it is an option w/o argument, we're almost finished with it.
  127.     if ( $type eq '' || $type eq '!' || $type eq '+' ) {
  128.     if ( defined $optarg ) {
  129.         return (0) if $passthrough;
  130.         warn ("Option ", $opt, " does not take an argument\n");
  131.         $error++;
  132.         undef $opt;
  133.     }
  134.     elsif ( $type eq '' || $type eq '+' ) {
  135.         $arg = 1;        # supply explicit value
  136.         $incr = $type eq '+';
  137.     }
  138.     else {
  139.         substr ($opt, 0, 2) = ''; # strip NO prefix
  140.         $arg = 0;        # supply explicit value
  141.     }
  142.     unshift (@ARGV, $starter.$rest) if defined $rest;
  143.     return (1, $opt,$arg,$dsttype,$incr,$key);
  144.     }
  145.  
  146.     # Get mandatory status and type info.
  147.     my $mand;
  148.     ($mand, $type, $dsttype, $key) = $type =~ /^(.)(.)([@%]?)$/;
  149.  
  150.     # Check if there is an option argument available.
  151.     if ( defined $optarg ? ($optarg eq '')
  152.      : !(defined $rest || @ARGV > 0) ) {
  153.     # Complain if this option needs an argument.
  154.     if ( $mand eq "=" ) {
  155.         return (0) if $passthrough;
  156.         warn ("Option ", $opt, " requires an argument\n");
  157.         $error++;
  158.         undef $opt;
  159.     }
  160.     if ( $mand eq ":" ) {
  161.         $arg = $type eq "s" ? '' : 0;
  162.     }
  163.     return (1, $opt,$arg,$dsttype,$incr,$key);
  164.     }
  165.  
  166.     # Get (possibly optional) argument.
  167.     $arg = (defined $rest ? $rest
  168.         : (defined $optarg ? $optarg : shift (@ARGV)));
  169.  
  170.     # Get key if this is a "name=value" pair for a hash option.
  171.     $key = undef;
  172.     if ($dsttype eq '%' && defined $arg) {
  173.     ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2) : ($arg, 1);
  174.     }
  175.  
  176.     #### Check if the argument is valid for this option ####
  177.  
  178.     if ( $type eq "s" ) {    # string
  179.     # A mandatory string takes anything.
  180.     return (1, $opt,$arg,$dsttype,$incr,$key) if $mand eq "=";
  181.  
  182.     # An optional string takes almost anything.
  183.     return (1, $opt,$arg,$dsttype,$incr,$key)
  184.       if defined $optarg || defined $rest;
  185.     return (1, $opt,$arg,$dsttype,$incr,$key) if $arg eq "-"; # ??
  186.  
  187.     # Check for option or option list terminator.
  188.     if ($arg eq $argend ||
  189.         $arg =~ /^$prefix.+/) {
  190.         # Push back.
  191.         unshift (@ARGV, $arg);
  192.         # Supply empty value.
  193.         $arg = '';
  194.     }
  195.     }
  196.  
  197.     elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer
  198.     if ( $bundling && defined $rest && $rest =~ /^([-+]?[0-9]+)(.*)$/s ) {
  199.         $arg = $1;
  200.         $rest = $2;
  201.         unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
  202.     }
  203.     elsif ( $arg !~ /^[-+]?[0-9]+$/ ) {
  204.         if ( defined $optarg || $mand eq "=" ) {
  205.         if ( $passthrough ) {
  206.             unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
  207.               unless defined $optarg;
  208.             return (0);
  209.         }
  210.         warn ("Value \"", $arg, "\" invalid for option ",
  211.               $opt, " (number expected)\n");
  212.         $error++;
  213.         undef $opt;
  214.         # Push back.
  215.         unshift (@ARGV, $starter.$rest) if defined $rest;
  216.         }
  217.         else {
  218.         # Push back.
  219.         unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
  220.         # Supply default value.
  221.         $arg = 0;
  222.         }
  223.     }
  224.     }
  225.  
  226.     elsif ( $type eq "f" ) { # real number, int is also ok
  227.     # We require at least one digit before a point or 'e',
  228.     # and at least one digit following the point and 'e'.
  229.     # [-]NN[.NN][eNN]
  230.     if ( $bundling && defined $rest &&
  231.          $rest =~ /^([-+]?[0-9]+(\.[0-9]+)?([eE][-+]?[0-9]+)?)(.*)$/s ) {
  232.         $arg = $1;
  233.         $rest = $+;
  234.         unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
  235.     }
  236.     elsif ( $arg !~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/ ) {
  237.         if ( defined $optarg || $mand eq "=" ) {
  238.         if ( $passthrough ) {
  239.             unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
  240.               unless defined $optarg;
  241.             return (0);
  242.         }
  243.         warn ("Value \"", $arg, "\" invalid for option ",
  244.               $opt, " (real number expected)\n");
  245.         $error++;
  246.         undef $opt;
  247.         # Push back.
  248.         unshift (@ARGV, $starter.$rest) if defined $rest;
  249.         }
  250.         else {
  251.         # Push back.
  252.         unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
  253.         # Supply default value.
  254.         $arg = 0.0;
  255.         }
  256.     }
  257.     }
  258.     else {
  259.     Croak ("GetOpt::Long internal error (Can't happen)\n");
  260.     }
  261.     return (1, $opt, $arg, $dsttype, $incr, $key);
  262. }
  263.  
  264. # end of Getopt::Long::FindOption
  265. 1;
  266.