home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_mlb.zip / getopts.pl < prev    next >
Text File  |  1997-11-25  |  942b  |  50 lines
  1. ;# getopts.pl - a better getopt.pl
  2.  
  3. ;# Usage:
  4. ;#      do Getopts('a:bc');  # -a takes arg. -b & -c not. Sets opt_* as a
  5. ;#                           #  side effect.
  6.  
  7. sub Getopts {
  8.     local($argumentative) = @_;
  9.     local(@args,$_,$first,$rest);
  10.     local($errs) = 0;
  11.  
  12.     @args = split( / */, $argumentative );
  13.     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  14.     ($first,$rest) = ($1,$2);
  15.     $pos = index($argumentative,$first);
  16.     if($pos >= 0) {
  17.         if($pos < $#args && $args[$pos+1] eq ':') {
  18.         shift(@ARGV);
  19.         if($rest eq '') {
  20.             ++$errs unless @ARGV;
  21.             $rest = shift(@ARGV);
  22.         }
  23.         ${"opt_$first"} = $rest;
  24.         }
  25.         else {
  26.         ${"opt_$first"} = 1;
  27.         if($rest eq '') {
  28.             shift(@ARGV);
  29.         }
  30.         else {
  31.             $ARGV[0] = "-$rest";
  32.         }
  33.         }
  34.     }
  35.     else {
  36.         print STDERR "Unknown option: $first\n";
  37.         ++$errs;
  38.         if($rest ne '') {
  39.         $ARGV[0] = "-$rest";
  40.         }
  41.         else {
  42.         shift(@ARGV);
  43.         }
  44.     }
  45.     }
  46.     $errs == 0;
  47. }
  48.  
  49. 1;
  50.