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