lib/perl5/5.6.1/auto/Getopt/Long/GetOptions.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 226 "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;