1package Getopt::Std; 2require 5.000; 3require Exporter; 4 5=head1 NAME 6 7getopt - Process single-character switches with switch clustering 8 9getopts - 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 23The getopt() functions processes single-character switches with switch 24clustering. Pass one argument which is a string containing all switches 25that take an argument. For each switch found, sets $opt_x (where x is the 26switch name) to the value of the argument, or 1 if no argument. Switches 27which take an argument don't care whether there is a space between the 28switch and the argument. 29 30Note that, if your code is running under the recommended C<use strict 31'vars'> pragma, you will need to declare these package variables 32with "our": 33 34 our($opt_foo, $opt_bar); 35 36For those of you who don't like additional global variables being created, getopt() 37and getopts() will also accept a hash reference as an optional second argument. 38Hash keys will be x (where x is the switch name) with key values the value of 39the argument or 1 if no argument is specified. 40 41To allow programs to process arguments that look like switches, but aren't, 42both functions will stop processing switches when they see the argument 43C<-->. 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 60sub 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 113sub 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 1761; 177