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