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