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() function 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 The getopts() function is similar, but you should pass to it the list of all
  31 switches to be recognized.  If unspecified switches are found on the
  32 command-line, the user will be warned that an unknown option was given.
  33
  34 Note that, if your code is running under the recommended C<use strict
  35 'vars'> pragma, you will need to declare these package variables
  36 with "our":
  37
  38     our($opt_x, $opt_y);
  39
  40 For those of you who don't like additional global variables being created, getopt()
  41 and getopts() will also accept a hash reference as an optional second argument.
  42 Hash keys will be x (where x is the switch name) with key values the value of
  43 the argument or 1 if no argument is specified.
  44
  45 To allow programs to process arguments that look like switches, but aren't,
  46 both functions will stop processing switches when they see the argument
  47 C<-->.  The C<--> will be removed from @ARGV.
  48
  49 =cut
  50
  51 @ISA = qw(Exporter);
  52 @EXPORT = qw(getopt getopts);
  53 $VERSION = '1.03';
  54
  55 # Process single-character switches with switch clustering.  Pass one argument
  56 # which is a string containing all switches that take an argument.  For each
  57 # switch found, sets $opt_x (where x is the switch name) to the value of the
  58 # argument, or 1 if no argument.  Switches which take an argument don't care
  59 # whether there is a space between the switch and the argument.
  60
  61 # Usage:
  62 #       getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
  63
  64 sub getopt (;$$) {
  65     my ($argumentative, $hash) = @_;
  66     $argumentative = '' if !defined $argumentative;
  67     my ($first,$rest);
  68     local $_;
  69     local @EXPORT;
  70
  71     while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  72         ($first,$rest) = ($1,$2);
  73         if (/^--$/) {   # early exit if --
  74             shift @ARGV;
  75             last;
  76         }
  77         if (index($argumentative,$first) >= 0) {
  78             if ($rest ne '') {
  79                 shift(@ARGV);
  80             }
  81             else {
  82                 shift(@ARGV);
  83                 $rest = shift(@ARGV);
  84             }
  85             if (ref $hash) {
  86                 $$hash{$first} = $rest;
  87             }
  88             else {
  89                 ${"opt_$first"} = $rest;
  90                 push( @EXPORT, "\$opt_$first" );
  91             }
  92         }
  93         else {
  94             if (ref $hash) {
  95                 $$hash{$first} = 1;
  96             }
  97             else {
  98                 ${"opt_$first"} = 1;
  99                 push( @EXPORT, "\$opt_$first" );
 100             }
 101             if ($rest ne '') {
 102                 $ARGV[0] = "-$rest";
 103             }
 104             else {
 105                 shift(@ARGV);
 106             }
 107         }
 108     }
 109     unless (ref $hash) {
 110         local $Exporter::ExportLevel = 1;
 111         import Getopt::Std;
 112     }
 113 }
 114
 115 # Usage:
 116 #   getopts('a:bc');    # -a takes arg. -b & -c not. Sets opt_* as a
 117 #                       #  side effect.
 118
 119 sub getopts ($;$) {
 120     my ($argumentative, $hash) = @_;
 121     my (@args,$first,$rest);
 122     my $errs = 0;
 123     local $_;
 124     local @EXPORT;
 125
 126     @args = split( / */, $argumentative );
 127     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
 128         ($first,$rest) = ($1,$2);
 129         if (/^--$/) {   # early exit if --
 130             shift @ARGV;
 131             last;
 132         }
 133         $pos = index($argumentative,$first);
 134         if ($pos >= 0) {
 135             if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
 136                 shift(@ARGV);
 137                 if ($rest eq '') {
 138                     ++$errs unless @ARGV;
 139                     $rest = shift(@ARGV);
 140                 }
 141                 if (ref $hash) {
 142                     $$hash{$first} = $rest;
 143                 }
 144                 else {
 145                     ${"opt_$first"} = $rest;
 146                     push( @EXPORT, "\$opt_$first" );
 147                 }
 148             }
 149             else {
 150                 if (ref $hash) {
 151                     $$hash{$first} = 1;
 152                 }
 153                 else {
 154                     ${"opt_$first"} = 1;
 155                     push( @EXPORT, "\$opt_$first" );
 156                 }
 157                 if ($rest eq '') {
 158                     shift(@ARGV);
 159                 }
 160                 else {
 161                     $ARGV[0] = "-$rest";
 162                 }
 163             }
 164         }
 165         else {
 166             warn "Unknown option: $first\n";
 167             ++$errs;
 168             if ($rest ne '') {
 169                 $ARGV[0] = "-$rest";
 170             }
 171             else {
 172                 shift(@ARGV);
 173             }
 174         }
 175     }
 176     unless (ref $hash) {
 177         local $Exporter::ExportLevel = 1;
 178         import Getopt::Std;
 179     }
 180     $errs == 0;
 181 }
 182
 183 1;