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