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 warn( "The 'getopts.pl' legacy library is deprecated and will be"
  12       . " removed in the next major release of perl. Please use the"
  13       . " Getopt::Long or Getopt::Std module instead." );
  14
  15 ;# Usage:
  16 ;#      do Getopts('a:bc');  # -a takes arg. -b & -c not. Sets opt_* as a
  17 ;#                           #  side effect.
  18
  19 sub Getopts {
  20     local($argumentative) = @_;
  21     local(@args,$_,$first,$rest);
  22     local($errs) = 0;
  23     local($[) = 0;
  24
  25     @args = split( / */, $argumentative );
  26     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  27                 ($first,$rest) = ($1,$2);
  28                 $pos = index($argumentative,$first);
  29                 if($pos >= $[) {
  30                         if($args[$pos+1] eq ':') {
  31                                 shift(@ARGV);
  32                                 if($rest eq '') {
  33                                         ++$errs unless(@ARGV);
  34                                         $rest = shift(@ARGV);
  35                                 }
  36                                 eval "
  37                                 push(\@opt_$first, \$rest);
  38                                 if (!defined \$opt_$first or \$opt_$first eq '') {
  39                                         \$opt_$first = \$rest;
  40                                 }
  41                                 else {
  42                                         \$opt_$first .= ' ' . \$rest;
  43                                 }
  44                                 ";
  45                         }
  46                         else {
  47                                 eval "\$opt_$first = 1";
  48                                 if($rest eq '') {
  49                                         shift(@ARGV);
  50                                 }
  51                                 else {
  52                                         $ARGV[0] = "-$rest";
  53                                 }
  54                         }
  55                 }
  56                 else {
  57                         print STDERR "Unknown option: $first\n";
  58                         ++$errs;
  59                         if($rest ne '') {
  60                                 $ARGV[0] = "-$rest";
  61                         }
  62                         else {
  63                                 shift(@ARGV);
  64                         }
  65                 }
  66         }
  67     $errs == 0;
  68 }
  69
  70 1;