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