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
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.
17                       # Sets $opt_* as a side effect.
18     getopt('oDI', \%opts);    # -o, -D & -I take arg.  Values in %opts
19
20 =head1 DESCRIPTION
21
22 The getopts() function processes single-character switches with switch
23 clustering.  Pass one argument which is a string containing all switches
24 to be recognized.  For each switch found, sets $opt_x (where x is the
25 switch name) to the value of the argument if an argument is expected,
26 or 1 otherwise.  Switches which take an argument don't care whether
27 there is a space between the switch and the argument.  If unspecified switches
28 are found on the command-line, the user will be warned that an unknown
29 option was given.  The getopts() function returns true unless an invalid
30 option was found.
31
32 The getopt() function is similar, but its argument is a string containing
33 all switches that take an argument.  Unspecified switches are silently
34 accepted.  Its use is not recommended.
35
36 Note that, if your code is running under the recommended C<use strict
37 'vars'> pragma, you will need to declare these package variables
38 with "our":
39
40     our($opt_x, $opt_y);
41
42 For those of you who don't like additional global variables being created, getopt()
43 and getopts() will also accept a hash reference as an optional second argument. 
44 Hash keys will be x (where x is the switch name) with key values the value of
45 the argument or 1 if no argument is specified.
46
47 To allow programs to process arguments that look like switches, but aren't,
48 both functions will stop processing switches when they see the argument
49 C<-->.  The C<--> will be removed from @ARGV.
50
51 =head1 C<--help> and C<--version>
52
53 If C<-> is not a recognized switch letter, getopts() supports arguments
54 C<--help> and C<--version>.  If C<main::HELP_MESSAGE()> and/or
55 C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are
56 the output file handle, the name of option-processing package, its version,
57 and the switches string.  If the subroutines are not defined, an attempt is
58 made to generate intelligent messages; for best results, define $main::VERSION.
59
60 If embedded documentation (in pod format, see L<perlpod>) is detected
61 in the script, C<--help> will also show how to access the documentation.
62
63 Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION
64 isn't true (the default is false), then the messages are printed on STDERR,
65 and the processing continues after the messages are printed.  This being
66 the opposite of the standard-conforming behaviour, it is strongly recommended
67 to set $Getopt::Std::STANDARD_HELP_VERSION to true.
68
69 One 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()
72 and version_mess() with the switches string as an argument.
73
74 =cut
75
76 @ISA = qw(Exporter);
77 @EXPORT = qw(getopt getopts);
78 $VERSION = '1.09';
79 # uncomment the next line to disable 1.03-backward compatibility paranoia
80 # $STANDARD_HELP_VERSION = 1;
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
91 sub getopt (;$$) {
92     my ($argumentative, $hash) = @_;
93     $argumentative = '' if !defined $argumentative;
94     my ($first,$rest);
95     local $_;
96     local @EXPORT;
97
98     while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
99         ($first,$rest) = ($1,$2);
100         if (/^--$/) {   # early exit if --
101             shift @ARGV;
102             last;
103         }
104         if (index($argumentative,$first) >= 0) {
105             if ($rest ne '') {
106                 shift(@ARGV);
107             }
108             else {
109                 shift(@ARGV);
110                 $rest = shift(@ARGV);
111             }
112             if (ref $hash) {
113                 $$hash{$first} = $rest;
114             }
115             else {
116                 ${"opt_$first"} = $rest;
117                 push( @EXPORT, "\$opt_$first" );
118             }
119         }
120         else {
121             if (ref $hash) {
122                 $$hash{$first} = 1;
123             }
124             else {
125                 ${"opt_$first"} = 1;
126                 push( @EXPORT, "\$opt_$first" );
127             }
128             if ($rest ne '') {
129                 $ARGV[0] = "-$rest";
130             }
131             else {
132                 shift(@ARGV);
133             }
134         }
135     }
136     unless (ref $hash) { 
137         local $Exporter::ExportLevel = 1;
138         import Getopt::Std;
139     }
140 }
141
142 sub output_h () {
143   return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION;
144   return \*STDOUT if $STANDARD_HELP_VERSION;
145   return \*STDERR;
146 }
147
148 sub 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.
153    See 'perldoc $p' about \$$p\::STANDARD_HELP_VERSION.]
154 EOM
155 }
156
157 sub 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),
171 running under Perl version $perlv.
172 EOH
173     }
174 }
175
176 sub 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
194
195 Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...]
196 EOH
197         print $h <<EOH;
198
199 The following single-character options are accepted:$help
200
201 Options may be merged together.  -- stops processing of options.$arg
202 EOH
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
212 For more details run
213         perldoc -F $0
214 EOH
215     }
216 }
217
218 # Usage:
219 #   getopts('a:bc');    # -a takes arg. -b & -c not. Sets opt_* as a
220 #                       #  side effect.
221
222 sub getopts ($;$) {
223     my ($argumentative, $hash) = @_;
224     my (@args,$first,$rest,$exit);
225     my $errs = 0;
226     local $_;
227     local @EXPORT;
228
229     @args = split( / */, $argumentative );
230     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) {
231         ($first,$rest) = ($1,$2);
232         if (/^--$/) {   # early exit if --
233             shift @ARGV;
234             last;
235         }
236         my $pos = index($argumentative,$first);
237         if ($pos >= 0) {
238             if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
239                 shift(@ARGV);
240                 if ($rest eq '') {
241                     ++$errs unless @ARGV;
242                     $rest = shift(@ARGV);
243                 }
244                 if (ref $hash) {
245                     $$hash{$first} = $rest;
246                 }
247                 else {
248                     ${"opt_$first"} = $rest;
249                     push( @EXPORT, "\$opt_$first" );
250                 }
251             }
252             else {
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 '') {
261                     shift(@ARGV);
262                 }
263                 else {
264                     $ARGV[0] = "-$rest";
265                 }
266             }
267         }
268         else {
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             }
281             warn "Unknown option: $first\n";
282             ++$errs;
283             if ($rest ne '') {
284                 $ARGV[0] = "-$rest";
285             }
286             else {
287                 shift(@ARGV);
288             }
289         }
290     }
291     unless (ref $hash) { 
292         local $Exporter::ExportLevel = 1;
293         import Getopt::Std;
294     }
295     $errs == 0;
296 }
297
298 1;