Commit | Line | Data |
---|---|---|
a0d0e21e LW |
1 | package Getopt::Std; |
2 | require 5.000; | |
3 | require Exporter; | |
4 | ||
f06db76b AD |
5 | =head1 NAME |
6 | ||
c7bcd97d | 7 | getopt, getopts - Process single-character switches with switch clustering |
f06db76b AD |
8 | |
9 | =head1 SYNOPSIS | |
10 | ||
11 | use Getopt::Std; | |
0bc14741 | 12 | |
f06db76b | 13 | getopts('oif:'); # -o & -i are boolean flags, -f takes an argument |
12527e6c | 14 | # Sets $opt_* as a side effect. |
0bc14741 | 15 | getopts('oif:', \%opts); # options as above. Values in %opts |
555bd962 BG |
16 | getopt('oDI'); # -o, -D & -I take arg. |
17 | # Sets $opt_* as a side effect. | |
0c0a84c6 | 18 | getopt('oDI', \%opts); # -o, -D & -I take arg. Values in %opts |
f06db76b AD |
19 | |
20 | =head1 DESCRIPTION | |
21 | ||
243ac78f JK |
22 | The C<getopts()> function processes single-character switches with switch |
23 | clustering. Pass one argument which is a string containing all switches to be | |
24 | recognized. For each switch found, if an argument is expected and provided, | |
25 | C<getopts()> sets C<$opt_x> (where C<x> is the switch name) to the value of | |
26 | the argument. If an argument is expected but none is provided, C<$opt_x> is | |
27 | set to an undefined value. If a switch does not take an argument, C<$opt_x> | |
28 | is set to C<1>. | |
29 | ||
30 | Switches which take an argument don't care whether there is a space between | |
31 | the switch and the argument. If unspecified switches are found on the | |
32 | command-line, the user will be warned that an unknown option was given. | |
33 | ||
34 | The C<getopts()> function returns true unless an invalid option was found. | |
35 | ||
36 | The C<getopt()> function is similar, but its argument is a string containing | |
37 | all switches that take an argument. If no argument is provided for a switch, | |
38 | say, C<y>, the corresponding C<$opt_y> will be set to an undefined value. | |
624c6f90 JK |
39 | Unspecified switches are silently accepted. Use of C<getopt()> is not |
40 | recommended. | |
12527e6c | 41 | |
535b5725 | 42 | Note that, if your code is running under the recommended C<use strict |
243ac78f JK |
43 | vars> pragma, you will need to declare these package variables |
44 | with C<our>: | |
535b5725 | 45 | |
12527e6c | 46 | our($opt_x, $opt_y); |
535b5725 | 47 | |
243ac78f JK |
48 | For those of you who don't like additional global variables being created, |
49 | C<getopt()> and C<getopts()> will also accept a hash reference as an optional | |
50 | second argument. Hash keys will be C<x> (where C<x> is the switch name) with | |
51 | key values the value of the argument or C<1> if no argument is specified. | |
0bc14741 | 52 | |
5812d790 GS |
53 | To allow programs to process arguments that look like switches, but aren't, |
54 | both functions will stop processing switches when they see the argument | |
55 | C<-->. The C<--> will be removed from @ARGV. | |
56 | ||
294d099e IZ |
57 | =head1 C<--help> and C<--version> |
58 | ||
59 | If C<-> is not a recognized switch letter, getopts() supports arguments | |
60 | C<--help> and C<--version>. If C<main::HELP_MESSAGE()> and/or | |
61 | C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are | |
62 | the output file handle, the name of option-processing package, its version, | |
63 | and the switches string. If the subroutines are not defined, an attempt is | |
64 | made to generate intelligent messages; for best results, define $main::VERSION. | |
65 | ||
669ecdbc IZ |
66 | If embedded documentation (in pod format, see L<perlpod>) is detected |
67 | in the script, C<--help> will also show how to access the documentation. | |
68 | ||
294d099e IZ |
69 | Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION |
70 | isn't true (the default is false), then the messages are printed on STDERR, | |
71 | and the processing continues after the messages are printed. This being | |
72 | the opposite of the standard-conforming behaviour, it is strongly recommended | |
73 | to set $Getopt::Std::STANDARD_HELP_VERSION to true. | |
74 | ||
75 | One 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() | |
78 | and version_mess() with the switches string as an argument. | |
79 | ||
f06db76b AD |
80 | =cut |
81 | ||
a0d0e21e LW |
82 | @ISA = qw(Exporter); |
83 | @EXPORT = qw(getopt getopts); | |
624c6f90 | 84 | $VERSION = '1.11'; |
294d099e IZ |
85 | # uncomment the next line to disable 1.03-backward compatibility paranoia |
86 | # $STANDARD_HELP_VERSION = 1; | |
a0d0e21e LW |
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 | ||
12527e6c RGS |
97 | sub getopt (;$$) { |
98 | my ($argumentative, $hash) = @_; | |
99 | $argumentative = '' if !defined $argumentative; | |
100 | my ($first,$rest); | |
101 | local $_; | |
6ca64377 | 102 | local @EXPORT; |
a0d0e21e LW |
103 | |
104 | while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { | |
105 | ($first,$rest) = ($1,$2); | |
5812d790 GS |
106 | if (/^--$/) { # early exit if -- |
107 | shift @ARGV; | |
108 | last; | |
109 | } | |
a0d0e21e LW |
110 | if (index($argumentative,$first) >= 0) { |
111 | if ($rest ne '') { | |
112 | shift(@ARGV); | |
113 | } | |
114 | else { | |
115 | shift(@ARGV); | |
116 | $rest = shift(@ARGV); | |
117 | } | |
5812d790 GS |
118 | if (ref $hash) { |
119 | $$hash{$first} = $rest; | |
120 | } | |
121 | else { | |
122 | ${"opt_$first"} = $rest; | |
123 | push( @EXPORT, "\$opt_$first" ); | |
124 | } | |
a0d0e21e LW |
125 | } |
126 | else { | |
5812d790 GS |
127 | if (ref $hash) { |
128 | $$hash{$first} = 1; | |
129 | } | |
130 | else { | |
131 | ${"opt_$first"} = 1; | |
132 | push( @EXPORT, "\$opt_$first" ); | |
133 | } | |
a0d0e21e LW |
134 | if ($rest ne '') { |
135 | $ARGV[0] = "-$rest"; | |
136 | } | |
137 | else { | |
138 | shift(@ARGV); | |
139 | } | |
140 | } | |
141 | } | |
6ca64377 RB |
142 | unless (ref $hash) { |
143 | local $Exporter::ExportLevel = 1; | |
144 | import Getopt::Std; | |
145 | } | |
a0d0e21e LW |
146 | } |
147 | ||
294d099e IZ |
148 | sub output_h () { |
149 | return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION; | |
150 | return \*STDOUT if $STANDARD_HELP_VERSION; | |
151 | return \*STDERR; | |
152 | } | |
153 | ||
154 | sub 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. | |
1f874cb6 | 159 | See 'perldoc $p' about \$$p\::STANDARD_HELP_VERSION.] |
294d099e IZ |
160 | EOM |
161 | } | |
162 | ||
163 | sub 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), | |
177 | running under Perl version $perlv. | |
178 | EOH | |
179 | } | |
180 | } | |
181 | ||
182 | sub 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 | |
669ecdbc | 200 | |
294d099e IZ |
201 | Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...] |
202 | EOH | |
203 | print $h <<EOH; | |
669ecdbc | 204 | |
294d099e | 205 | The following single-character options are accepted:$help |
669ecdbc | 206 | |
294d099e IZ |
207 | Options may be merged together. -- stops processing of options.$arg |
208 | EOH | |
669ecdbc IZ |
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 | ||
218 | For more details run | |
219 | perldoc -F $0 | |
220 | EOH | |
294d099e IZ |
221 | } |
222 | } | |
223 | ||
a0d0e21e LW |
224 | # Usage: |
225 | # getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a | |
226 | # # side effect. | |
227 | ||
0bc14741 | 228 | sub getopts ($;$) { |
12527e6c | 229 | my ($argumentative, $hash) = @_; |
294d099e | 230 | my (@args,$first,$rest,$exit); |
12527e6c RGS |
231 | my $errs = 0; |
232 | local $_; | |
6ca64377 | 233 | local @EXPORT; |
a0d0e21e LW |
234 | |
235 | @args = split( / */, $argumentative ); | |
294d099e | 236 | while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) { |
a0d0e21e | 237 | ($first,$rest) = ($1,$2); |
5812d790 GS |
238 | if (/^--$/) { # early exit if -- |
239 | shift @ARGV; | |
240 | last; | |
241 | } | |
294d099e | 242 | my $pos = index($argumentative,$first); |
5812d790 GS |
243 | if ($pos >= 0) { |
244 | if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) { | |
a0d0e21e | 245 | shift(@ARGV); |
5812d790 | 246 | if ($rest eq '') { |
a0d0e21e LW |
247 | ++$errs unless @ARGV; |
248 | $rest = shift(@ARGV); | |
249 | } | |
5812d790 GS |
250 | if (ref $hash) { |
251 | $$hash{$first} = $rest; | |
252 | } | |
253 | else { | |
254 | ${"opt_$first"} = $rest; | |
255 | push( @EXPORT, "\$opt_$first" ); | |
256 | } | |
a0d0e21e LW |
257 | } |
258 | else { | |
5812d790 GS |
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 '') { | |
a0d0e21e LW |
267 | shift(@ARGV); |
268 | } | |
269 | else { | |
270 | $ARGV[0] = "-$rest"; | |
271 | } | |
272 | } | |
273 | } | |
274 | else { | |
294d099e IZ |
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 | } | |
55118cb0 | 287 | warn "Unknown option: $first\n"; |
a0d0e21e | 288 | ++$errs; |
5812d790 | 289 | if ($rest ne '') { |
a0d0e21e LW |
290 | $ARGV[0] = "-$rest"; |
291 | } | |
292 | else { | |
293 | shift(@ARGV); | |
294 | } | |
295 | } | |
296 | } | |
6ca64377 RB |
297 | unless (ref $hash) { |
298 | local $Exporter::ExportLevel = 1; | |
299 | import Getopt::Std; | |
300 | } | |
a0d0e21e LW |
301 | $errs == 0; |
302 | } | |
303 | ||
304 | 1; |