| 1 | | | | | package Getopt::Std; |
| 2 | 1 | 16µs | | | require 5.000; |
| 3 | 1 | 600ns | | | require Exporter; |
| 4 | | | | | |
| 5 | | | | | =head1 NAME |
| 6 | | | | | |
| 7 | | | | | 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 | | | | | |
| 21 | | | | | The getopt() function processes single-character switches with switch |
| 22 | | | | | clustering. Pass one argument which is a string containing all switches |
| 23 | | | | | that take an argument. For each switch found, sets $opt_x (where x is the |
| 24 | | | | | switch name) to the value of the argument if an argument is expected, |
| 25 | | | | | or 1 otherwise. Switches which take an argument don't care whether |
| 26 | | | | | there is a space between the switch and the argument. |
| 27 | | | | | |
| 28 | | | | | The getopts() function is similar, but you should pass to it the list of all |
| 29 | | | | | switches to be recognized. If unspecified switches are found on the |
| 30 | | | | | command-line, the user will be warned that an unknown option was given. |
| 31 | | | | | The getopts() function returns true unless an invalid option was found. |
| 32 | | | | | |
| 33 | | | | | Note that, if your code is running under the recommended C<use strict |
| 34 | | | | | 'vars'> pragma, you will need to declare these package variables |
| 35 | | | | | with "our": |
| 36 | | | | | |
| 37 | | | | | our($opt_x, $opt_y); |
| 38 | | | | | |
| 39 | | | | | For those of you who don't like additional global variables being created, getopt() |
| 40 | | | | | and getopts() will also accept a hash reference as an optional second argument. |
| 41 | | | | | Hash keys will be x (where x is the switch name) with key values the value of |
| 42 | | | | | the argument or 1 if no argument is specified. |
| 43 | | | | | |
| 44 | | | | | To allow programs to process arguments that look like switches, but aren't, |
| 45 | | | | | both functions will stop processing switches when they see the argument |
| 46 | | | | | C<-->. The C<--> will be removed from @ARGV. |
| 47 | | | | | |
| 48 | | | | | =head1 C<--help> and C<--version> |
| 49 | | | | | |
| 50 | | | | | If C<-> is not a recognized switch letter, getopts() supports arguments |
| 51 | | | | | C<--help> and C<--version>. If C<main::HELP_MESSAGE()> and/or |
| 52 | | | | | C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are |
| 53 | | | | | the output file handle, the name of option-processing package, its version, |
| 54 | | | | | and the switches string. If the subroutines are not defined, an attempt is |
| 55 | | | | | made to generate intelligent messages; for best results, define $main::VERSION. |
| 56 | | | | | |
| 57 | | | | | If embedded documentation (in pod format, see L<perlpod>) is detected |
| 58 | | | | | in the script, C<--help> will also show how to access the documentation. |
| 59 | | | | | |
| 60 | | | | | Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION |
| 61 | | | | | isn't true (the default is false), then the messages are printed on STDERR, |
| 62 | | | | | and the processing continues after the messages are printed. This being |
| 63 | | | | | the opposite of the standard-conforming behaviour, it is strongly recommended |
| 64 | | | | | to set $Getopt::Std::STANDARD_HELP_VERSION to true. |
| 65 | | | | | |
| 66 | | | | | One 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() |
| 69 | | | | | and version_mess() with the switches string as an argument. |
| 70 | | | | | |
| 71 | | | | | =cut |
| 72 | | | | | |
| 73 | 1 | 8µs | | | @ISA = qw(Exporter); |
| 74 | 1 | 600ns | | | @EXPORT = qw(getopt getopts); |
| 75 | 1 | 300ns | | | $VERSION = '1.06'; |
| 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 | | | | | |
| 88 | | | | | sub 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 | | | | | |
| 139 | | | | | sub output_h () { |
| 140 | | | | | return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION; |
| 141 | | | | | return \*STDOUT if $STANDARD_HELP_VERSION; |
| 142 | | | | | return \*STDERR; |
| 143 | | | | | } |
| 144 | | | | | |
| 145 | | | | | sub 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.] |
| 151 | | | | | EOM |
| 152 | | | | | } |
| 153 | | | | | |
| 154 | | | | | sub 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), |
| 168 | | | | | running under Perl version $perlv. |
| 169 | | | | | EOH |
| 170 | | | | | } |
| 171 | | | | | } |
| 172 | | | | | |
| 173 | | | | | sub 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 | | | | | |
| 192 | | | | | Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...] |
| 193 | | | | | EOH |
| 194 | | | | | print $h <<EOH; |
| 195 | | | | | |
| 196 | | | | | The following single-character options are accepted:$help |
| 197 | | | | | |
| 198 | | | | | Options may be merged together. -- stops processing of options.$arg |
| 199 | | | | | EOH |
| 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 | | | | | |
| 209 | | | | | For more details run |
| 210 | | | | | perldoc -F $0 |
| 211 | | | | | EOH |
| 212 | | | | | } |
| 213 | | | | | } |
| 214 | | | | | |
| 215 | | | | | # Usage: |
| 216 | | | | | # getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a |
| 217 | | | | | # # side effect. |
| 218 | | | | | |
| 219 | | | | | sub 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 | | | | | |
| 295 | 1 | 4µs | | | 1; |