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 Note that, if your code is running under the recommended C<use strict
  31 'vars'> pragma, it may be helpful to declare these package variables
  32 via C<use vars> perhaps something like this:
  33
  34     use vars qw/ $opt_foo $opt_bar /;
  35
  36 For those of you who don't like additional variables being created, getopt()
  37 and getopts() will also accept a hash reference as an optional second argument.
  38 Hash keys will be x (where x is the switch name) with key values the value of
  39 the argument or 1 if no argument is specified.
  40
  41 =cut
  42
  43 @ISA = qw(Exporter);
  44 @EXPORT = qw(getopt getopts);
  45
  46 # $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $
  47
  48 # Process single-character switches with switch clustering.  Pass one argument
  49 # which is a string containing all switches that take an argument.  For each
  50 # switch found, sets $opt_x (where x is the switch name) to the value of the
  51 # argument, or 1 if no argument.  Switches which take an argument don't care
  52 # whether there is a space between the switch and the argument.
  53
  54 # Usage:
  55 #       getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
  56
  57 sub getopt ($;$) {
  58     local($argumentative, $hash) = @_;
  59     local($_,$first,$rest);
  60     local @EXPORT;
  61
  62     while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  63         ($first,$rest) = ($1,$2);
  64         if (index($argumentative,$first) >= 0) {
  65             if ($rest ne '') {
  66                 shift(@ARGV);
  67             }
  68             else {
  69                 shift(@ARGV);
  70                 $rest = shift(@ARGV);
  71             }
  72           if (ref $hash) {
  73               $$hash{$first} = $rest;
  74           }
  75           else {
  76               ${"opt_$first"} = $rest;
  77               push( @EXPORT, "\$opt_$first" );
  78           }
  79         }
  80         else {
  81           if (ref $hash) {
  82               $$hash{$first} = 1;
  83           }
  84           else {
  85               ${"opt_$first"} = 1;
  86               push( @EXPORT, "\$opt_$first" );
  87           }
  88             if ($rest ne '') {
  89                 $ARGV[0] = "-$rest";
  90             }
  91             else {
  92                 shift(@ARGV);
  93             }
  94         }
  95     }
  96     unless (ref $hash) {
  97         local $Exporter::ExportLevel = 1;
  98         import Getopt::Std;
  99     }
 100 }
 101
 102 # Usage:
 103 #   getopts('a:bc');    # -a takes arg. -b & -c not. Sets opt_* as a
 104 #                       #  side effect.
 105
 106 sub getopts ($;$) {
 107     local($argumentative, $hash) = @_;
 108     local(@args,$_,$first,$rest);
 109     local($errs) = 0;
 110     local @EXPORT;
 111
 112     @args = split( / */, $argumentative );
 113     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
 114         ($first,$rest) = ($1,$2);
 115         $pos = index($argumentative,$first);
 116         if($pos >= 0) {
 117             if(defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
 118                 shift(@ARGV);
 119                 if($rest eq '') {
 120                     ++$errs unless @ARGV;
 121                     $rest = shift(@ARGV);
 122                 }
 123               if (ref $hash) {
 124                   $$hash{$first} = $rest;
 125               }
 126               else {
 127                   ${"opt_$first"} = $rest;
 128                   push( @EXPORT, "\$opt_$first" );
 129               }
 130             }
 131             else {
 132               if (ref $hash) {
 133                   $$hash{$first} = 1;
 134               }
 135               else {
 136                   ${"opt_$first"} = 1;
 137                   push( @EXPORT, "\$opt_$first" );
 138               }
 139                 if($rest eq '') {
 140                     shift(@ARGV);
 141                 }
 142                 else {
 143                     $ARGV[0] = "-$rest";
 144                 }
 145             }
 146         }
 147         else {
 148             print STDERR "Unknown option: $first\n";
 149             ++$errs;
 150             if($rest ne '') {
 151                 $ARGV[0] = "-$rest";
 152             }
 153             else {
 154                 shift(@ARGV);
 155             }
 156         }
 157     }
 158     unless (ref $hash) {
 159         local $Exporter::ExportLevel = 1;
 160         import Getopt::Std;
 161     }
 162     $errs == 0;
 163 }
 164
 165 1;
 166