1package Getopt::Std; 2require 5.000; 3require Exporter; 4 5=head1 NAME 6 7getopt, getopts - Process single-character switches with switch clustering 8 9=head1 SYNOPSIS 10 11 use Getopt::Std; 12 13 getopt('oDI'); # -o, -D & -I take arg. Sets $opt_* as a side effect. 14 getopt('oDI', \%opts); # -o, -D & -I take arg. Values in %opts 15 getopts('oif:'); # -o & -i are boolean flags, -f takes an argument 16 # Sets $opt_* as a side effect. 17 getopts('oif:', \%opts); # options as above. Values in %opts 18 19=head1 DESCRIPTION 20 21The getopt() function processes single-character switches with switch 22clustering. Pass one argument which is a string containing all switches 23that take an argument. For each switch found, sets $opt_x (where x is the 24switch name) to the value of the argument if an argument is expected, 25or 1 otherwise. Switches which take an argument don't care whether 26there is a space between the switch and the argument. 27 28The getopts() function is similar, but you should pass to it the list of all 29switches to be recognized. If unspecified switches are found on the 30command-line, the user will be warned that an unknown option was given. 31 32Note that, if your code is running under the recommended C<use strict 33'vars'> pragma, you will need to declare these package variables 34with "our": 35 36 our($opt_x, $opt_y); 37 38For those of you who don't like additional global variables being created, getopt() 39and getopts() will also accept a hash reference as an optional second argument. 40Hash keys will be x (where x is the switch name) with key values the value of 41the argument or 1 if no argument is specified. 42 43To allow programs to process arguments that look like switches, but aren't, 44both functions will stop processing switches when they see the argument 45C<-->. The C<--> will be removed from @ARGV. 46 47=head1 C<--help> and C<--version> 48 49If C<-> is not a recognized switch letter, getopts() supports arguments 50C<--help> and C<--version>. If C<main::HELP_MESSAGE()> and/or 51C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are 52the output file handle, the name of option-processing package, its version, 53and the switches string. If the subroutines are not defined, an attempt is 54made to generate intelligent messages; for best results, define $main::VERSION. 55 56If embedded documentation (in pod format, see L<perlpod>) is detected 57in the script, C<--help> will also show how to access the documentation. 58 59Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION 60isn't true (the default is false), then the messages are printed on STDERR, 61and the processing continues after the messages are printed. This being 62the opposite of the standard-conforming behaviour, it is strongly recommended 63to set $Getopt::Std::STANDARD_HELP_VERSION to true. 64 65One can change the output file handle of the messages by setting 66$Getopt::Std::OUTPUT_HELP_VERSION. One can print the messages of C<--help> 67(without the C<Usage:> line) and C<--version> by calling functions help_mess() 68and version_mess() with the switches string as an argument. 69 70=cut 71 72@ISA = qw(Exporter); 73@EXPORT = qw(getopt getopts); 74$VERSION = '1.05'; 75# uncomment the next line to disable 1.03-backward compatibility paranoia 76# $STANDARD_HELP_VERSION = 1; 77 78# Process single-character switches with switch clustering. Pass one argument 79# which is a string containing all switches that take an argument. For each 80# switch found, sets $opt_x (where x is the switch name) to the value of the 81# argument, or 1 if no argument. Switches which take an argument don't care 82# whether there is a space between the switch and the argument. 83 84# Usage: 85# getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. 86 87sub getopt (;$$) { 88 my ($argumentative, $hash) = @_; 89 $argumentative = '' if !defined $argumentative; 90 my ($first,$rest); 91 local $_; 92 local @EXPORT; 93 94 while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { 95 ($first,$rest) = ($1,$2); 96 if (/^--$/) { # early exit if -- 97 shift @ARGV; 98 last; 99 } 100 if (index($argumentative,$first) >= 0) { 101 if ($rest ne '') { 102 shift(@ARGV); 103 } 104 else { 105 shift(@ARGV); 106 $rest = shift(@ARGV); 107 } 108 if (ref $hash) { 109 $$hash{$first} = $rest; 110 } 111 else { 112 ${"opt_$first"} = $rest; 113 push( @EXPORT, "\$opt_$first" ); 114 } 115 } 116 else { 117 if (ref $hash) { 118 $$hash{$first} = 1; 119 } 120 else { 121 ${"opt_$first"} = 1; 122 push( @EXPORT, "\$opt_$first" ); 123 } 124 if ($rest ne '') { 125 $ARGV[0] = "-$rest"; 126 } 127 else { 128 shift(@ARGV); 129 } 130 } 131 } 132 unless (ref $hash) { 133 local $Exporter::ExportLevel = 1; 134 import Getopt::Std; 135 } 136} 137 138sub output_h () { 139 return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION; 140 return \*STDOUT if $STANDARD_HELP_VERSION; 141 return \*STDERR; 142} 143 144sub try_exit () { 145 exit 0 if $STANDARD_HELP_VERSION; 146 my $p = __PACKAGE__; 147 print {output_h()} <<EOM; 148 [Now continuing due to backward compatibility and excessive paranoia. 149 See ``perldoc $p'' about \$$p\::STANDARD_HELP_VERSION.] 150EOM 151} 152 153sub version_mess ($;$) { 154 my $args = shift; 155 my $h = output_h; 156 if (@_ and defined &main::VERSION_MESSAGE) { 157 main::VERSION_MESSAGE($h, __PACKAGE__, $VERSION, $args); 158 } else { 159 my $v = $main::VERSION; 160 $v = '[unknown]' unless defined $v; 161 my $myv = $VERSION; 162 $myv .= ' [paranoid]' unless $STANDARD_HELP_VERSION; 163 my $perlv = $]; 164 $perlv = sprintf "%vd", $^V if $] >= 5.006; 165 print $h <<EOH; 166$0 version $v calling Getopt::Std::getopts (version $myv), 167running under Perl version $perlv. 168EOH 169 } 170} 171 172sub help_mess ($;$) { 173 my $args = shift; 174 my $h = output_h; 175 if (@_ and defined &main::HELP_MESSAGE) { 176 main::HELP_MESSAGE($h, __PACKAGE__, $VERSION, $args); 177 } else { 178 my (@witharg) = ($args =~ /(\S)\s*:/g); 179 my (@rest) = ($args =~ /([^\s:])(?!\s*:)/g); 180 my ($help, $arg) = ('', ''); 181 if (@witharg) { 182 $help .= "\n\tWith arguments: -" . join " -", @witharg; 183 $arg = "\nSpace is not required between options and their arguments."; 184 } 185 if (@rest) { 186 $help .= "\n\tBoolean (without arguments): -" . join " -", @rest; 187 } 188 my ($scr) = ($0 =~ m,([^/\\]+)$,); 189 print $h <<EOH if @_; # Let the script override this 190 191Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...] 192EOH 193 print $h <<EOH; 194 195The following single-character options are accepted:$help 196 197Options may be merged together. -- stops processing of options.$arg 198EOH 199 my $has_pod; 200 if ( defined $0 and $0 ne '-e' and -f $0 and -r $0 201 and open my $script, '<', $0 ) { 202 while (<$script>) { 203 $has_pod = 1, last if /^=(pod|head1)/; 204 } 205 } 206 print $h <<EOH if $has_pod; 207 208For more details run 209 perldoc -F $0 210EOH 211 } 212} 213 214# Usage: 215# getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a 216# # side effect. 217 218sub getopts ($;$) { 219 my ($argumentative, $hash) = @_; 220 my (@args,$first,$rest,$exit); 221 my $errs = 0; 222 local $_; 223 local @EXPORT; 224 225 @args = split( / */, $argumentative ); 226 while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) { 227 ($first,$rest) = ($1,$2); 228 if (/^--$/) { # early exit if -- 229 shift @ARGV; 230 last; 231 } 232 my $pos = index($argumentative,$first); 233 if ($pos >= 0) { 234 if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) { 235 shift(@ARGV); 236 if ($rest eq '') { 237 ++$errs unless @ARGV; 238 $rest = shift(@ARGV); 239 } 240 if (ref $hash) { 241 $$hash{$first} = $rest; 242 } 243 else { 244 ${"opt_$first"} = $rest; 245 push( @EXPORT, "\$opt_$first" ); 246 } 247 } 248 else { 249 if (ref $hash) { 250 $$hash{$first} = 1; 251 } 252 else { 253 ${"opt_$first"} = 1; 254 push( @EXPORT, "\$opt_$first" ); 255 } 256 if ($rest eq '') { 257 shift(@ARGV); 258 } 259 else { 260 $ARGV[0] = "-$rest"; 261 } 262 } 263 } 264 else { 265 if ($first eq '-' and $rest eq 'help') { 266 version_mess($argumentative, 'main'); 267 help_mess($argumentative, 'main'); 268 try_exit(); 269 shift(@ARGV); 270 next; 271 } elsif ($first eq '-' and $rest eq 'version') { 272 version_mess($argumentative, 'main'); 273 try_exit(); 274 shift(@ARGV); 275 next; 276 } 277 warn "Unknown option: $first\n"; 278 ++$errs; 279 if ($rest ne '') { 280 $ARGV[0] = "-$rest"; 281 } 282 else { 283 shift(@ARGV); 284 } 285 } 286 } 287 unless (ref $hash) { 288 local $Exporter::ExportLevel = 1; 289 import Getopt::Std; 290 } 291 $errs == 0; 292} 293 2941; 295