lib/Getopt/Std.pm

   1 package Getopt::Std;
   2 require 5.000;
   3 require Exporter;
   4
   5 =head1 NAME
   6
   7 getopt - Process single-character switches with switch clustering
   8
   9 getopts - Process single-character switches with switch clustering
  10
  11 =head1 SYNOPSIS
  12
  13     use Getopt::Std;
  14
  15     getopt('oDI');    # -o, -D & -I take arg.  Sets opt_* as a side effect.
  16     getopt('oDI', \%opts);    # -o, -D & -I take arg.  Values in %opts
  17     getopts('oif:');  # -o & -i are boolean flags, -f takes an argument
  18                       # Sets opt_* as a side effect.
  19     getopts('oif:', \%opts);  # options as above. Values in %opts
  20
  21 =head1 DESCRIPTION
  22
  23 The getopt() functions processes single-character switches with switch
  24 clustering.  Pass one argument which is a string containing all switches
  25 that take an argument.  For each switch found, sets $opt_x (where x is the
  26 switch name) to the value of the argument, or 1 if no argument.  Switches
  27 which take an argument don't care whether there is a space between the
  28 switch and the argument.
  29
  30 For those of you who don't like additional variables being created, getopt()
  31 and getopts() will also accept a hash reference as an optional second argument.
  32 Hash keys will be x (where x is the switch name) with key values the value of
  33 the argument or 1 if no argument is specified.
  34
  35 =cut
  36
  37 @ISA = qw(Exporter);
  38 @EXPORT = qw(getopt getopts);
  39
  40 # $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $
  41
  42 # Process single-character switches with switch clustering.  Pass one argument
  43 # which is a string containing all switches that take an argument.  For each
  44 # switch found, sets $opt_x (where x is the switch name) to the value of the
  45 # argument, or 1 if no argument.  Switches which take an argument don't care
  46 # whether there is a space between the switch and the argument.
  47
  48 # Usage:
  49 #       getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
  50
  51 sub getopt ($;$) {
  52     local($argumentative, $hash) = @_;
  53     local($_,$first,$rest);
  54     local $Exporter::ExportLevel;
  55
  56     while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  57         ($first,$rest) = ($1,$2);
  58         if (index($argumentative,$first) >= 0) {
  59             if ($rest ne '') {
  60                 shift(@ARGV);
  61             }
  62             else {
  63                 shift(@ARGV);
  64                 $rest = shift(@ARGV);
  65             }
  66           if (ref $hash) {
  67               $$hash{$first} = $rest;
  68           }
  69           else {
  70               eval "\$opt_$first = \$rest;";
  71               push( @EXPORT, "\$opt_$first" );
  72           }
  73         }
  74         else {
  75           if (ref $hash) {
  76               $$hash{$first} = 1;
  77           }
  78           else {
  79               eval "\$opt_$first = 1;";
  80               push( @EXPORT, "\$opt_$first" );
  81           }
  82             if ($rest ne '') {
  83                 $ARGV[0] = "-$rest";
  84             }
  85             else {
  86                 shift(@ARGV);
  87             }
  88         }
  89     }
  90     $Exporter::ExportLevel++;
  91     import Getopt::Std;
  92 }
  93
  94 # Usage:
  95 #   getopts('a:bc');    # -a takes arg. -b & -c not. Sets opt_* as a
  96 #                       #  side effect.
  97
  98 sub getopts ($;$) {
  99     local($argumentative, $hash) = @_;
 100     local(@args,$_,$first,$rest);
 101     local($errs) = 0;
 102     local $Exporter::ExportLevel;
 103
 104     @args = split( / */, $argumentative );
 105     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
 106         ($first,$rest) = ($1,$2);
 107         $pos = index($argumentative,$first);
 108         if($pos >= 0) {
 109             if(defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
 110                 shift(@ARGV);
 111                 if($rest eq '') {
 112                     ++$errs unless @ARGV;
 113                     $rest = shift(@ARGV);
 114                 }
 115               if (ref $hash) {
 116                   $$hash{$first} = $rest;
 117               }
 118               else {
 119                   eval "\$opt_$first = \$rest;";
 120                   push( @EXPORT, "\$opt_$first" );
 121               }
 122             }
 123             else {
 124               if (ref $hash) {
 125                   $$hash{$first} = 1;
 126               }
 127               else {
 128                   eval "\$opt_$first = 1";
 129                   push( @EXPORT, "\$opt_$first" );
 130               }
 131                 if($rest eq '') {
 132                     shift(@ARGV);
 133                 }
 134                 else {
 135                     $ARGV[0] = "-$rest";
 136                 }
 137             }
 138         }
 139         else {
 140             print STDERR "Unknown option: $first\n";
 141             ++$errs;
 142             if($rest ne '') {
 143                 $ARGV[0] = "-$rest";
 144             }
 145             else {
 146                 shift(@ARGV);
 147             }
 148         }
 149     }
 150     $Exporter::ExportLevel++;
 151     import Getopt::Std;
 152     $errs == 0;
 153 }
 154
 155 1;
 156