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