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 | |
58 | Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION |
59 | isn't true (the default is false), then the messages are printed on STDERR, |
60 | and the processing continues after the messages are printed. This being |
61 | the opposite of the standard-conforming behaviour, it is strongly recommended |
62 | to set $Getopt::Std::STANDARD_HELP_VERSION to true. |
63 | |
64 | One can change the output file handle of the messages by setting |
65 | $Getopt::Std::OUTPUT_HELP_VERSION. One can print the messages of C<--help> |
66 | (without the C<Usage:> line) and C<--version> by calling functions help_mess() |
67 | and version_mess() with the switches string as an argument. |
68 | |
f06db76b |
69 | =cut |
70 | |
a0d0e21e |
71 | @ISA = qw(Exporter); |
72 | @EXPORT = qw(getopt getopts); |
294d099e |
73 | $VERSION = '1.04'; |
74 | # uncomment the next line to disable 1.03-backward compatibility paranoia |
75 | # $STANDARD_HELP_VERSION = 1; |
a0d0e21e |
76 | |
77 | # Process single-character switches with switch clustering. Pass one argument |
78 | # which is a string containing all switches that take an argument. For each |
79 | # switch found, sets $opt_x (where x is the switch name) to the value of the |
80 | # argument, or 1 if no argument. Switches which take an argument don't care |
81 | # whether there is a space between the switch and the argument. |
82 | |
83 | # Usage: |
84 | # getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. |
85 | |
12527e6c |
86 | sub getopt (;$$) { |
87 | my ($argumentative, $hash) = @_; |
88 | $argumentative = '' if !defined $argumentative; |
89 | my ($first,$rest); |
90 | local $_; |
6ca64377 |
91 | local @EXPORT; |
a0d0e21e |
92 | |
93 | while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { |
94 | ($first,$rest) = ($1,$2); |
5812d790 |
95 | if (/^--$/) { # early exit if -- |
96 | shift @ARGV; |
97 | last; |
98 | } |
a0d0e21e |
99 | if (index($argumentative,$first) >= 0) { |
100 | if ($rest ne '') { |
101 | shift(@ARGV); |
102 | } |
103 | else { |
104 | shift(@ARGV); |
105 | $rest = shift(@ARGV); |
106 | } |
5812d790 |
107 | if (ref $hash) { |
108 | $$hash{$first} = $rest; |
109 | } |
110 | else { |
111 | ${"opt_$first"} = $rest; |
112 | push( @EXPORT, "\$opt_$first" ); |
113 | } |
a0d0e21e |
114 | } |
115 | else { |
5812d790 |
116 | if (ref $hash) { |
117 | $$hash{$first} = 1; |
118 | } |
119 | else { |
120 | ${"opt_$first"} = 1; |
121 | push( @EXPORT, "\$opt_$first" ); |
122 | } |
a0d0e21e |
123 | if ($rest ne '') { |
124 | $ARGV[0] = "-$rest"; |
125 | } |
126 | else { |
127 | shift(@ARGV); |
128 | } |
129 | } |
130 | } |
6ca64377 |
131 | unless (ref $hash) { |
132 | local $Exporter::ExportLevel = 1; |
133 | import Getopt::Std; |
134 | } |
a0d0e21e |
135 | } |
136 | |
294d099e |
137 | sub output_h () { |
138 | return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION; |
139 | return \*STDOUT if $STANDARD_HELP_VERSION; |
140 | return \*STDERR; |
141 | } |
142 | |
143 | sub try_exit () { |
144 | exit 0 if $STANDARD_HELP_VERSION; |
145 | my $p = __PACKAGE__; |
146 | print {output_h()} <<EOM; |
147 | [Now continuing due to backward compatibility and excessive paranoia. |
148 | See ``perldoc $p'' about \$$p\::STANDARD_HELP_VERSION.] |
149 | EOM |
150 | } |
151 | |
152 | sub version_mess ($;$) { |
153 | my $args = shift; |
154 | my $h = output_h; |
155 | if (@_ and defined &main::VERSION_MESSAGE) { |
156 | main::VERSION_MESSAGE($h, __PACKAGE__, $VERSION, $args); |
157 | } else { |
158 | my $v = $main::VERSION; |
159 | $v = '[unknown]' unless defined $v; |
160 | my $myv = $VERSION; |
161 | $myv .= ' [paranoid]' unless $STANDARD_HELP_VERSION; |
162 | my $perlv = $]; |
163 | $perlv = sprintf "%vd", $^V if $] >= 5.006; |
164 | print $h <<EOH; |
165 | $0 version $v calling Getopt::Std::getopts (version $myv), |
166 | running under Perl version $perlv. |
167 | EOH |
168 | } |
169 | } |
170 | |
171 | sub help_mess ($;$) { |
172 | my $args = shift; |
173 | my $h = output_h; |
174 | if (@_ and defined &main::HELP_MESSAGE) { |
175 | main::HELP_MESSAGE($h, __PACKAGE__, $VERSION, $args); |
176 | } else { |
177 | my (@witharg) = ($args =~ /(\S)\s*:/g); |
178 | my (@rest) = ($args =~ /([^\s:])(?!\s*:)/g); |
179 | my ($help, $arg) = ('', ''); |
180 | if (@witharg) { |
181 | $help .= "\n\tWith arguments: -" . join " -", @witharg; |
182 | $arg = "\nSpace is not required between options and their arguments."; |
183 | } |
184 | if (@rest) { |
185 | $help .= "\n\tBoolean (without arguments): -" . join " -", @rest; |
186 | } |
187 | my ($scr) = ($0 =~ m,([^/\\]+)$,); |
188 | print $h <<EOH if @_; # Let the script override this |
189 | Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...] |
190 | EOH |
191 | print $h <<EOH; |
192 | The following single-character options are accepted:$help |
193 | Options may be merged together. -- stops processing of options.$arg |
194 | EOH |
195 | } |
196 | } |
197 | |
a0d0e21e |
198 | # Usage: |
199 | # getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a |
200 | # # side effect. |
201 | |
0bc14741 |
202 | sub getopts ($;$) { |
12527e6c |
203 | my ($argumentative, $hash) = @_; |
294d099e |
204 | my (@args,$first,$rest,$exit); |
12527e6c |
205 | my $errs = 0; |
206 | local $_; |
6ca64377 |
207 | local @EXPORT; |
a0d0e21e |
208 | |
209 | @args = split( / */, $argumentative ); |
294d099e |
210 | while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) { |
a0d0e21e |
211 | ($first,$rest) = ($1,$2); |
5812d790 |
212 | if (/^--$/) { # early exit if -- |
213 | shift @ARGV; |
214 | last; |
215 | } |
294d099e |
216 | my $pos = index($argumentative,$first); |
5812d790 |
217 | if ($pos >= 0) { |
218 | if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) { |
a0d0e21e |
219 | shift(@ARGV); |
5812d790 |
220 | if ($rest eq '') { |
a0d0e21e |
221 | ++$errs unless @ARGV; |
222 | $rest = shift(@ARGV); |
223 | } |
5812d790 |
224 | if (ref $hash) { |
225 | $$hash{$first} = $rest; |
226 | } |
227 | else { |
228 | ${"opt_$first"} = $rest; |
229 | push( @EXPORT, "\$opt_$first" ); |
230 | } |
a0d0e21e |
231 | } |
232 | else { |
5812d790 |
233 | if (ref $hash) { |
234 | $$hash{$first} = 1; |
235 | } |
236 | else { |
237 | ${"opt_$first"} = 1; |
238 | push( @EXPORT, "\$opt_$first" ); |
239 | } |
240 | if ($rest eq '') { |
a0d0e21e |
241 | shift(@ARGV); |
242 | } |
243 | else { |
244 | $ARGV[0] = "-$rest"; |
245 | } |
246 | } |
247 | } |
248 | else { |
294d099e |
249 | if ($first eq '-' and $rest eq 'help') { |
250 | version_mess($argumentative, 'main'); |
251 | help_mess($argumentative, 'main'); |
252 | try_exit(); |
253 | shift(@ARGV); |
254 | next; |
255 | } elsif ($first eq '-' and $rest eq 'version') { |
256 | version_mess($argumentative, 'main'); |
257 | try_exit(); |
258 | shift(@ARGV); |
259 | next; |
260 | } |
55118cb0 |
261 | warn "Unknown option: $first\n"; |
a0d0e21e |
262 | ++$errs; |
5812d790 |
263 | if ($rest ne '') { |
a0d0e21e |
264 | $ARGV[0] = "-$rest"; |
265 | } |
266 | else { |
267 | shift(@ARGV); |
268 | } |
269 | } |
270 | } |
6ca64377 |
271 | unless (ref $hash) { |
272 | local $Exporter::ExportLevel = 1; |
273 | import Getopt::Std; |
274 | } |
a0d0e21e |
275 | $errs == 0; |
276 | } |
277 | |
278 | 1; |