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