home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Database Designers / Rational Rose 2000 / Rational Setup.EXE / common / lib / auto / Getopt / Long / GetOptions.al < prev   
Encoding:
Text File  |  1999-01-26  |  10.9 KB  |  399 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.20 1998-06-14 15:02:19+02 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: Sun Jun 14 13:54:35 1998
  14. # Update Count    : 24
  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)[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.20 $ ',
  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.     if ( $optionlist[0] =~ /^\W+$/ ) {
  66.     $genprefix = shift (@optionlist);
  67.     # Turn into regexp. Needs to be parenthesized!
  68.     $genprefix =~ s/(\W)/\\$1/g;
  69.     $genprefix = "([" . $genprefix . "])";
  70.     }
  71.  
  72.     # Verify correctness of optionlist.
  73.     %opctl = ();
  74.     %bopctl = ();
  75.     while ( @optionlist > 0 ) {
  76.     my $opt = shift (@optionlist);
  77.  
  78.     # Strip leading prefix so people can specify "--foo=i" if they like.
  79.     $opt = $+ if $opt =~ /^$genprefix+(.*)$/s;
  80.  
  81.     if ( $opt eq '<>' ) {
  82.         if ( (defined $userlinkage)
  83.         && !(@optionlist > 0 && ref($optionlist[0]))
  84.         && (exists $userlinkage->{$opt})
  85.         && ref($userlinkage->{$opt}) ) {
  86.         unshift (@optionlist, $userlinkage->{$opt});
  87.         }
  88.         unless ( @optionlist > 0 
  89.             && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
  90.         $error .= "Option spec <> requires a reference to a subroutine\n";
  91.         next;
  92.         }
  93.         $linkage{'<>'} = shift (@optionlist);
  94.         next;
  95.     }
  96.  
  97.     # Match option spec. Allow '?' as an alias.
  98.     if ( $opt !~ /^((\w+[-\w]*)(\|(\?|\w[-\w]*)?)*)?([!~+]|[=:][infse][@%]?)?$/ ) {
  99.         $error .= "Error in option spec: \"$opt\"\n";
  100.         next;
  101.     }
  102.     my ($o, $c, $a) = ($1, $5);
  103.     $c = '' unless defined $c;
  104.  
  105.     if ( ! defined $o ) {
  106.         # empty -> '-' option
  107.         $opctl{$o = ''} = $c;
  108.     }
  109.     else {
  110.         # Handle alias names
  111.         my @o =  split (/\|/, $o);
  112.         my $linko = $o = $o[0];
  113.         # Force an alias if the option name is not locase.
  114.         $a = $o unless $o eq lc($o);
  115.         $o = lc ($o)
  116.         if $ignorecase > 1 
  117.             || ($ignorecase
  118.             && ($bundling ? length($o) > 1  : 1));
  119.  
  120.         foreach ( @o ) {
  121.         if ( $bundling && length($_) == 1 ) {
  122.             $_ = lc ($_) if $ignorecase > 1;
  123.             if ( $c eq '!' ) {
  124.             $opctl{"no$_"} = $c;
  125.             warn ("Ignoring '!' modifier for short option $_\n");
  126.             $c = '';
  127.             }
  128.             $opctl{$_} = $bopctl{$_} = $c;
  129.         }
  130.         else {
  131.             $_ = lc ($_) if $ignorecase;
  132.             if ( $c eq '!' ) {
  133.             $opctl{"no$_"} = $c;
  134.             $c = '';
  135.             }
  136.             $opctl{$_} = $c;
  137.         }
  138.         if ( defined $a ) {
  139.             # Note alias.
  140.             $aliases{$_} = $a;
  141.         }
  142.         else {
  143.             # Set primary name.
  144.             $a = $_;
  145.         }
  146.         }
  147.         $o = $linko;
  148.     }
  149.  
  150.     # If no linkage is supplied in the @optionlist, copy it from
  151.     # the userlinkage if available.
  152.     if ( defined $userlinkage ) {
  153.         unless ( @optionlist > 0 && ref($optionlist[0]) ) {
  154.         if ( exists $userlinkage->{$o} && ref($userlinkage->{$o}) ) {
  155.             print STDERR ("=> found userlinkage for \"$o\": ",
  156.                   "$userlinkage->{$o}\n")
  157.             if $debug;
  158.             unshift (@optionlist, $userlinkage->{$o});
  159.         }
  160.         else {
  161.             # Do nothing. Being undefined will be handled later.
  162.             next;
  163.         }
  164.         }
  165.     }
  166.  
  167.     # Copy the linkage. If omitted, link to global variable.
  168.     if ( @optionlist > 0 && ref($optionlist[0]) ) {
  169.         print STDERR ("=> link \"$o\" to $optionlist[0]\n")
  170.         if $debug;
  171.         if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) {
  172.         $linkage{$o} = shift (@optionlist);
  173.         }
  174.         elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) {
  175.         $linkage{$o} = shift (@optionlist);
  176.         $opctl{$o} .= '@'
  177.           if $opctl{$o} ne '' and $opctl{$o} !~ /\@$/;
  178.         $bopctl{$o} .= '@'
  179.           if $bundling and defined $bopctl{$o} and 
  180.             $bopctl{$o} ne '' and $bopctl{$o} !~ /\@$/;
  181.         }
  182.         elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) {
  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.         else {
  191.         $error .= "Invalid option linkage for \"$opt\"\n";
  192.         }
  193.     }
  194.     else {
  195.         # Link to global $opt_XXX variable.
  196.         # Make sure a valid perl identifier results.
  197.         my $ov = $o;
  198.         $ov =~ s/\W/_/g;
  199.         if ( $c =~ /@/ ) {
  200.         print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n")
  201.             if $debug;
  202.         eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;");
  203.         }
  204.         elsif ( $c =~ /%/ ) {
  205.         print STDERR ("=> link \"$o\" to \%$pkg","::opt_$ov\n")
  206.             if $debug;
  207.         eval ("\$linkage{\$o} = \\\%".$pkg."::opt_$ov;");
  208.         }
  209.         else {
  210.         print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n")
  211.             if $debug;
  212.         eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;");
  213.         }
  214.     }
  215.     }
  216.  
  217.     # Bail out if errors found.
  218.     die ($error) if $error;
  219.     $error = 0;
  220.  
  221.     # Sort the possible long option names.
  222.     @opctl = sort(keys (%opctl)) if $autoabbrev;
  223.  
  224.     # Show the options tables if debugging.
  225.     if ( $debug ) {
  226.     my ($arrow, $k, $v);
  227.     $arrow = "=> ";
  228.     while ( ($k,$v) = each(%opctl) ) {
  229.         print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
  230.         $arrow = "   ";
  231.     }
  232.     $arrow = "=> ";
  233.     while ( ($k,$v) = each(%bopctl) ) {
  234.         print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n");
  235.         $arrow = "   ";
  236.     }
  237.     }
  238.  
  239.     # Process argument list
  240.     while ( @ARGV > 0 ) {
  241.  
  242.     #### Get next argument ####
  243.  
  244.     $opt = shift (@ARGV);
  245.     print STDERR ("=> option \"", $opt, "\"\n") if $debug;
  246.  
  247.     #### Determine what we have ####
  248.  
  249.     # Double dash is option list terminator.
  250.     if ( $opt eq $argend ) {
  251.         # Finish. Push back accumulated arguments and return.
  252.         unshift (@ARGV, @ret) 
  253.         if $order == $PERMUTE;
  254.         return ($error == 0);
  255.     }
  256.  
  257.     my $tryopt = $opt;
  258.     my $found;        # success status
  259.     my $dsttype;        # destination type ('@' or '%')
  260.     my $incr;        # destination increment 
  261.     my $key;        # key (if hash type)
  262.     my $arg;        # option argument
  263.  
  264.     ($found, $opt, $arg, $dsttype, $incr, $key) = 
  265.       FindOption ($genprefix, $argend, $opt, 
  266.               \%opctl, \%bopctl, \@opctl, \%aliases);
  267.  
  268.     if ( $found ) {
  269.         
  270.         # FindOption undefines $opt in case of errors.
  271.         next unless defined $opt;
  272.  
  273.         if ( defined $arg ) {
  274.         $opt = $aliases{$opt} if defined $aliases{$opt};
  275.  
  276.         if ( defined $linkage{$opt} ) {
  277.             print STDERR ("=> ref(\$L{$opt}) -> ",
  278.                   ref($linkage{$opt}), "\n") if $debug;
  279.  
  280.             if ( ref($linkage{$opt}) eq 'SCALAR' ) {
  281.             if ( $incr ) {
  282.                 print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
  283.                   if $debug;
  284.                 if ( defined ${$linkage{$opt}} ) {
  285.                     ${$linkage{$opt}} += $arg;
  286.                 }
  287.                     else {
  288.                     ${$linkage{$opt}} = $arg;
  289.                 }
  290.             }
  291.             else {
  292.                 print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
  293.                   if $debug;
  294.                 ${$linkage{$opt}} = $arg;
  295.                 }
  296.             }
  297.             elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
  298.             print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
  299.                 if $debug;
  300.             push (@{$linkage{$opt}}, $arg);
  301.             }
  302.             elsif ( ref($linkage{$opt}) eq 'HASH' ) {
  303.             print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
  304.                 if $debug;
  305.             $linkage{$opt}->{$key} = $arg;
  306.             }
  307.             elsif ( ref($linkage{$opt}) eq 'CODE' ) {
  308.             print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n")
  309.                 if $debug;
  310.             &{$linkage{$opt}}($opt, $arg);
  311.             }
  312.             else {
  313.             print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
  314.                       "\" in linkage\n");
  315.             Croak ("Getopt::Long -- internal error!\n");
  316.             }
  317.         }
  318.         # No entry in linkage means entry in userlinkage.
  319.         elsif ( $dsttype eq '@' ) {
  320.             if ( defined $userlinkage->{$opt} ) {
  321.             print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
  322.                 if $debug;
  323.             push (@{$userlinkage->{$opt}}, $arg);
  324.             }
  325.             else {
  326.             print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
  327.                 if $debug;
  328.             $userlinkage->{$opt} = [$arg];
  329.             }
  330.         }
  331.         elsif ( $dsttype eq '%' ) {
  332.             if ( defined $userlinkage->{$opt} ) {
  333.             print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
  334.                 if $debug;
  335.             $userlinkage->{$opt}->{$key} = $arg;
  336.             }
  337.             else {
  338.             print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
  339.                 if $debug;
  340.             $userlinkage->{$opt} = {$key => $arg};
  341.             }
  342.         }
  343.         else {
  344.             if ( $incr ) {
  345.             print STDERR ("=> \$L{$opt} += \"$arg\"\n")
  346.               if $debug;
  347.             if ( defined $userlinkage->{$opt} ) {
  348.                 $userlinkage->{$opt} += $arg;
  349.             }
  350.             else {
  351.                 $userlinkage->{$opt} = $arg;
  352.             }
  353.             }
  354.             else {
  355.             print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
  356.             $userlinkage->{$opt} = $arg;
  357.             }
  358.         }
  359.         }
  360.     }
  361.  
  362.     # Not an option. Save it if we $PERMUTE and don't have a <>.
  363.     elsif ( $order == $PERMUTE ) {
  364.         # Try non-options call-back.
  365.         my $cb;
  366.         if ( (defined ($cb = $linkage{'<>'})) ) {
  367.         &$cb ($tryopt);
  368.         }
  369.         else {
  370.         print STDERR ("=> saving \"$tryopt\" ",
  371.                   "(not an option, may permute)\n") if $debug;
  372.         push (@ret, $tryopt);
  373.         }
  374.         next;
  375.     }
  376.  
  377.     # ...otherwise, terminate.
  378.     else {
  379.         # Push this one back and exit.
  380.         unshift (@ARGV, $tryopt);
  381.         return ($error == 0);
  382.     }
  383.  
  384.     }
  385.  
  386.     # Finish.
  387.     if ( $order == $PERMUTE ) {
  388.     #  Push back accumulated arguments
  389.     print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
  390.         if $debug && @ret > 0;
  391.     unshift (@ARGV, @ret) if @ret > 0;
  392.     }
  393.  
  394.     return ($error == 0);
  395. }
  396.  
  397. # end of Getopt::Long::GetOptions
  398. 1;
  399.