This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH 5.8.1 @19053] Getopt::Std
[perl5.git] / lib / Getopt / Std.pm
CommitLineData
a0d0e21e
LW
1package Getopt::Std;
2require 5.000;
3require Exporter;
4
f06db76b
AD
5=head1 NAME
6
7getopt - Process single-character switches with switch clustering
8
9getopts - 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
AD
20
21=head1 DESCRIPTION
22
12527e6c 23The getopt() function processes single-character switches with switch
f06db76b
AD
24clustering. Pass one argument which is a string containing all switches
25that take an argument. For each switch found, sets $opt_x (where x is the
1b946c1e
JH
26switch name) to the value of the argument if an argument is expected,
27or 1 otherwise. Switches which take an argument don't care whether
28there is a space between the switch and the argument.
f06db76b 29
12527e6c
RGS
30The getopts() function is similar, but you should pass to it the list of all
31switches to be recognized. If unspecified switches are found on the
32command-line, the user will be warned that an unknown option was given.
33
535b5725 34Note that, if your code is running under the recommended C<use strict
5812d790
GS
35'vars'> pragma, you will need to declare these package variables
36with "our":
535b5725 37
12527e6c 38 our($opt_x, $opt_y);
535b5725 39
5812d790 40For those of you who don't like additional global variables being created, getopt()
0bc14741
SZ
41and getopts() will also accept a hash reference as an optional second argument.
42Hash keys will be x (where x is the switch name) with key values the value of
43the argument or 1 if no argument is specified.
44
5812d790
GS
45To allow programs to process arguments that look like switches, but aren't,
46both functions will stop processing switches when they see the argument
47C<-->. The C<--> will be removed from @ARGV.
48
294d099e
IZ
49=head1 C<--help> and C<--version>
50
51If C<-> is not a recognized switch letter, getopts() supports arguments
52C<--help> and C<--version>. If C<main::HELP_MESSAGE()> and/or
53C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are
54the output file handle, the name of option-processing package, its version,
55and the switches string. If the subroutines are not defined, an attempt is
56made to generate intelligent messages; for best results, define $main::VERSION.
57
669ecdbc
IZ
58If embedded documentation (in pod format, see L<perlpod>) is detected
59in the script, C<--help> will also show how to access the documentation.
60
294d099e
IZ
61Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION
62isn't true (the default is false), then the messages are printed on STDERR,
63and the processing continues after the messages are printed. This being
64the opposite of the standard-conforming behaviour, it is strongly recommended
65to set $Getopt::Std::STANDARD_HELP_VERSION to true.
66
67One 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()
70and version_mess() with the switches string as an argument.
71
f06db76b
AD
72=cut
73
a0d0e21e
LW
74@ISA = qw(Exporter);
75@EXPORT = qw(getopt getopts);
294d099e
IZ
76$VERSION = '1.04';
77# uncomment the next line to disable 1.03-backward compatibility paranoia
78# $STANDARD_HELP_VERSION = 1;
a0d0e21e
LW
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
RGS
89sub getopt (;$$) {
90 my ($argumentative, $hash) = @_;
91 $argumentative = '' if !defined $argumentative;
92 my ($first,$rest);
93 local $_;
6ca64377 94 local @EXPORT;
a0d0e21e
LW
95
96 while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
97 ($first,$rest) = ($1,$2);
5812d790
GS
98 if (/^--$/) { # early exit if --
99 shift @ARGV;
100 last;
101 }
a0d0e21e
LW
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
GS
110 if (ref $hash) {
111 $$hash{$first} = $rest;
112 }
113 else {
114 ${"opt_$first"} = $rest;
115 push( @EXPORT, "\$opt_$first" );
116 }
a0d0e21e
LW
117 }
118 else {
5812d790
GS
119 if (ref $hash) {
120 $$hash{$first} = 1;
121 }
122 else {
123 ${"opt_$first"} = 1;
124 push( @EXPORT, "\$opt_$first" );
125 }
a0d0e21e
LW
126 if ($rest ne '') {
127 $ARGV[0] = "-$rest";
128 }
129 else {
130 shift(@ARGV);
131 }
132 }
133 }
6ca64377
RB
134 unless (ref $hash) {
135 local $Exporter::ExportLevel = 1;
136 import Getopt::Std;
137 }
a0d0e21e
LW
138}
139
294d099e
IZ
140sub output_h () {
141 return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION;
142 return \*STDOUT if $STANDARD_HELP_VERSION;
143 return \*STDERR;
144}
145
146sub 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.]
152EOM
153}
154
155sub 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),
169running under Perl version $perlv.
170EOH
171 }
172}
173
174sub 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
IZ
193Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...]
194EOH
195 print $h <<EOH;
669ecdbc 196
294d099e 197The following single-character options are accepted:$help
669ecdbc 198
294d099e
IZ
199Options may be merged together. -- stops processing of options.$arg
200EOH
669ecdbc
IZ
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
210For more details run
211 perldoc -F $0
212EOH
294d099e
IZ
213 }
214}
215
a0d0e21e
LW
216# Usage:
217# getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
218# # side effect.
219
0bc14741 220sub getopts ($;$) {
12527e6c 221 my ($argumentative, $hash) = @_;
294d099e 222 my (@args,$first,$rest,$exit);
12527e6c
RGS
223 my $errs = 0;
224 local $_;
6ca64377 225 local @EXPORT;
a0d0e21e
LW
226
227 @args = split( / */, $argumentative );
294d099e 228 while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) {
a0d0e21e 229 ($first,$rest) = ($1,$2);
5812d790
GS
230 if (/^--$/) { # early exit if --
231 shift @ARGV;
232 last;
233 }
294d099e 234 my $pos = index($argumentative,$first);
5812d790
GS
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
LW
239 ++$errs unless @ARGV;
240 $rest = shift(@ARGV);
241 }
5812d790
GS
242 if (ref $hash) {
243 $$hash{$first} = $rest;
244 }
245 else {
246 ${"opt_$first"} = $rest;
247 push( @EXPORT, "\$opt_$first" );
248 }
a0d0e21e
LW
249 }
250 else {
5812d790
GS
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
LW
259 shift(@ARGV);
260 }
261 else {
262 $ARGV[0] = "-$rest";
263 }
264 }
265 }
266 else {
294d099e
IZ
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
LW
282 $ARGV[0] = "-$rest";
283 }
284 else {
285 shift(@ARGV);
286 }
287 }
288 }
6ca64377
RB
289 unless (ref $hash) {
290 local $Exporter::ExportLevel = 1;
291 import Getopt::Std;
292 }
a0d0e21e
LW
293 $errs == 0;
294}
295
2961;