lib/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
  20     @args = split( / */, $argumentative );
  21     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  22                 ($first,$rest) = ($1,$2);
  23                 $pos = index($argumentative,$first);
  24                 if($pos >= 0) {
  25                         if($args[$pos+1] eq ':') {
  26                                 shift(@ARGV);
  27                                 if($rest eq '') {
  28                                         ++$errs unless(@ARGV);
  29                                         $rest = shift(@ARGV);
  30                                 }
  31                                 eval "
  32                                 push(\@opt_$first, \$rest);
  33                                 if (!defined \$opt_$first or \$opt_$first eq '') {
  34                                         \$opt_$first = \$rest;
  35                                 }
  36                                 else {
  37                                         \$opt_$first .= ' ' . \$rest;
  38                                 }
  39                                 ";
  40                         }
  41                         else {
  42                                 eval "\$opt_$first = 1";
  43                                 if($rest eq '') {
  44                                         shift(@ARGV);
  45                                 }
  46                                 else {
  47                                         $ARGV[0] = "-$rest";
  48                                 }
  49                         }
  50                 }
  51                 else {
  52                         print STDERR "Unknown option: $first\n";
  53                         ++$errs;
  54                         if($rest ne '') {
  55                                 $ARGV[0] = "-$rest";
  56                         }
  57                         else {
  58                                 shift(@ARGV);
  59                         }
  60                 }
  61         }
  62     $errs == 0;
  63 }
  64
  65 1;