lib/getopts.pl

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