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     getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
  15     getopts('oif:');  # -o & -i are boolean flags, -f takes an argument
  16                       # Sets opt_* as a side effect.
  17
  18 =head1 DESCRIPTION
  19
  20 The getopt() functions processes single-character switches with switch
  21 clustering.  Pass one argument which is a string containing all switches
  22 that take an argument.  For each switch found, sets $opt_x (where x is the
  23 switch name) to the value of the argument, or 1 if no argument.  Switches
  24 which take an argument don't care whether there is a space between the
  25 switch and the argument.
  26
  27 =cut
  28
  29 @ISA = qw(Exporter);
  30 @EXPORT = qw(getopt getopts);
  31
  32 # $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $
  33
  34 # Process single-character switches with switch clustering.  Pass one argument
  35 # which is a string containing all switches that take an argument.  For each
  36 # switch found, sets $opt_x (where x is the switch name) to the value of the
  37 # argument, or 1 if no argument.  Switches which take an argument don't care
  38 # whether there is a space between the switch and the argument.
  39
  40 # Usage:
  41 #       getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
  42
  43 sub getopt {
  44     local($argumentative) = @_;
  45     local($_,$first,$rest);
  46     local $Exporter::ExportLevel;
  47
  48     while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  49         ($first,$rest) = ($1,$2);
  50         if (index($argumentative,$first) >= 0) {
  51             if ($rest ne '') {
  52                 shift(@ARGV);
  53             }
  54             else {
  55                 shift(@ARGV);
  56                 $rest = shift(@ARGV);
  57             }
  58             eval "\$opt_$first = \$rest;";
  59             push( @EXPORT, "\$opt_$first" );
  60         }
  61         else {
  62             eval "\$opt_$first = 1;";
  63             push( @EXPORT, "\$opt_$first" );
  64             if ($rest ne '') {
  65                 $ARGV[0] = "-$rest";
  66             }
  67             else {
  68                 shift(@ARGV);
  69             }
  70         }
  71     }
  72     $Exporter::ExportLevel++;
  73     import Getopt::Std;
  74 }
  75
  76 # Usage:
  77 #   getopts('a:bc');    # -a takes arg. -b & -c not. Sets opt_* as a
  78 #                       #  side effect.
  79
  80 sub getopts {
  81     local($argumentative) = @_;
  82     local(@args,$_,$first,$rest);
  83     local($errs) = 0;
  84     local $Exporter::ExportLevel;
  85
  86     @args = split( / */, $argumentative );
  87     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  88         ($first,$rest) = ($1,$2);
  89         $pos = index($argumentative,$first);
  90         if($pos >= 0) {
  91             if(defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
  92                 shift(@ARGV);
  93                 if($rest eq '') {
  94                     ++$errs unless @ARGV;
  95                     $rest = shift(@ARGV);
  96                 }
  97                 eval "\$opt_$first = \$rest;";
  98                 push( @EXPORT, "\$opt_$first" );
  99             }
 100             else {
 101                 eval "\$opt_$first = 1";
 102                 push( @EXPORT, "\$opt_$first" );
 103                 if($rest eq '') {
 104                     shift(@ARGV);
 105                 }
 106                 else {
 107                     $ARGV[0] = "-$rest";
 108                 }
 109             }
 110         }
 111         else {
 112             print STDERR "Unknown option: $first\n";
 113             ++$errs;
 114             if($rest ne '') {
 115                 $ARGV[0] = "-$rest";
 116             }
 117             else {
 118                 shift(@ARGV);
 119             }
 120         }
 121     }
 122     $Exporter::ExportLevel++;
 123     import Getopt::Std;
 124     $errs == 0;
 125 }
 126
 127 1;
 128