lib/Getopt/Std.pm

   1 package Getopt::Std;
   2 require 5.000;
   3 require Exporter;
   4
   5 @ISA = qw(Exporter);
   6 @EXPORT = qw(getopt getopts);
   7
   8 # $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $
   9
  10 # Process single-character switches with switch clustering.  Pass one argument
  11 # which is a string containing all switches that take an argument.  For each
  12 # switch found, sets $opt_x (where x is the switch name) to the value of the
  13 # argument, or 1 if no argument.  Switches which take an argument don't care
  14 # whether there is a space between the switch and the argument.
  15
  16 # Usage:
  17 #       getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
  18
  19 sub getopt {
  20     local($argumentative) = @_;
  21     local($_,$first,$rest);
  22     local $Exporter::ExportLevel;
  23
  24     while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  25         ($first,$rest) = ($1,$2);
  26         if (index($argumentative,$first) >= 0) {
  27             if ($rest ne '') {
  28                 shift(@ARGV);
  29             }
  30             else {
  31                 shift(@ARGV);
  32                 $rest = shift(@ARGV);
  33             }
  34             eval "\$opt_$first = \$rest;";
  35             push( @EXPORT, "\$opt_$first" );
  36         }
  37         else {
  38             eval "\$opt_$first = 1;";
  39             push( @EXPORT, "\$opt_$first" );
  40             if ($rest ne '') {
  41                 $ARGV[0] = "-$rest";
  42             }
  43             else {
  44                 shift(@ARGV);
  45             }
  46         }
  47     }
  48     $Exporter::ExportLevel++;
  49     import Getopt::Std;
  50 }
  51
  52 # Usage:
  53 #   getopts('a:bc');    # -a takes arg. -b & -c not. Sets opt_* as a
  54 #                       #  side effect.
  55
  56 sub getopts {
  57     local($argumentative) = @_;
  58     local(@args,$_,$first,$rest);
  59     local($errs) = 0;
  60     local $Exporter::ExportLevel;
  61
  62     @args = split( / */, $argumentative );
  63     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  64         ($first,$rest) = ($1,$2);
  65         $pos = index($argumentative,$first);
  66         if($pos >= 0) {
  67             if($args[$pos+1] eq ':') {
  68                 shift(@ARGV);
  69                 if($rest eq '') {
  70                     ++$errs unless @ARGV;
  71                     $rest = shift(@ARGV);
  72                 }
  73                 eval "\$opt_$first = \$rest;";
  74                 push( @EXPORT, "\$opt_$first" );
  75             }
  76             else {
  77                 eval "\$opt_$first = 1";
  78                 push( @EXPORT, "\$opt_$first" );
  79                 if($rest eq '') {
  80                     shift(@ARGV);
  81                 }
  82                 else {
  83                     $ARGV[0] = "-$rest";
  84                 }
  85             }
  86         }
  87         else {
  88             print STDERR "Unknown option: $first\n";
  89             ++$errs;
  90             if($rest ne '') {
  91                 $ARGV[0] = "-$rest";
  92             }
  93             else {
  94                 shift(@ARGV);
  95             }
  96         }
  97     }
  98     $Exporter::ExportLevel++;
  99     import Getopt::Std;
 100     $errs == 0;
 101 }
 102
 103 1;
 104