lib/perl5/5.6.1/auto/Getopt/Long/FindOption.al

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