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