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