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