lib/perl5/5.6.1/getopts.pl

   1 ;# getopts.pl - a better getopt.pl
   2 #
   3 # This library is no longer being maintained, and is included for backward
   4 # compatibility with Perl 4 programs which may require it.
   5 #
   6 # In particular, this should not be used as an example of modern Perl
   7 # programming techniques.
   8 #
   9 # Suggested alternatives: Getopt::Long  or  Getopt::Std
  10 #
  11 ;# Usage:
  12 ;#      do Getopts('a:bc');  # -a takes arg. -b & -c not. Sets opt_* as a
  13 ;#                           #  side effect.
  14
  15 sub Getopts {
  16     local($argumentative) = @_;
  17     local(@args,$_,$first,$rest);
  18     local($errs) = 0;
  19     local($[) = 0;
  20
  21     @args = split( / */, $argumentative );
  22     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  23                 ($first,$rest) = ($1,$2);
  24                 $pos = index($argumentative,$first);
  25                 if($pos >= $[) {
  26                         if($args[$pos+1] eq ':') {
  27                                 shift(@ARGV);
  28                                 if($rest eq '') {
  29                                         ++$errs unless(@ARGV);
  30                                         $rest = shift(@ARGV);
  31                                 }
  32                                 eval "
  33                                 push(\@opt_$first, \$rest);
  34                                 if(\$opt_$first eq '') {
  35                                         \$opt_$first = \$rest;
  36                                 }
  37                                 else {
  38                                         \$opt_$first .= ' ' . \$rest;
  39                                 }
  40                                 ";
  41                         }
  42                         else {
  43                                 eval "\$opt_$first = 1";
  44                                 if($rest eq '') {
  45                                         shift(@ARGV);
  46                                 }
  47                                 else {
  48                                         $ARGV[0] = "-$rest";
  49                                 }
  50                         }
  51                 }
  52                 else {
  53                         print STDERR "Unknown option: $first\n";
  54                         ++$errs;
  55                         if($rest ne '') {
  56                                 $ARGV[0] = "-$rest";
  57                         }
  58                         else {
  59                                 shift(@ARGV);
  60                         }
  61                 }
  62         }
  63     $errs == 0;
  64 }
  65
  66 1;