summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/lib/Getopt/Std.pm
blob: 5b8878dbb860fe5b325a65dc3fe07b9592f0b6e0 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
package Getopt::Std;
require 5.000;
require Exporter;

=head1 NAME

Getopt::Std - Process single-character switches with switch clustering

=head1 SYNOPSIS

    use Getopt::Std;

    getopts('oif:');  # -o & -i are boolean flags, -f takes an argument
		      # Sets $opt_* as a side effect.
    getopts('oif:', \%opts);  # options as above. Values in %opts
    getopt('oDI');    # -o, -D & -I take arg.
                      # Sets $opt_* as a side effect.
    getopt('oDI', \%opts);    # -o, -D & -I take arg.  Values in %opts

=head1 DESCRIPTION

The C<getopts()> function processes single-character switches with switch
clustering.  Pass one argument which is a string containing all switches to be
recognized.  For each switch found, if an argument is expected and provided,
C<getopts()> sets C<$opt_x> (where C<x> is the switch name) to the value of
the argument.  If an argument is expected but none is provided, C<$opt_x> is
set to an undefined value.  If a switch does not take an argument, C<$opt_x>
is set to C<1>.

Switches which take an argument don't care whether there is a space between
the switch and the argument.  If unspecified switches are found on the
command-line, the user will be warned that an unknown option was given.

The C<getopts()> function returns true unless an invalid option was found.

The C<getopt()> function is similar, but its argument is a string containing
all switches that take an argument.  If no argument is provided for a switch,
say, C<y>, the corresponding C<$opt_y> will be set to an undefined value.
Unspecified switches are silently accepted.  Use of C<getopt()> is not
recommended.

Note that, if your code is running under the recommended C<use strict
vars> pragma, you will need to declare these package variables
with C<our>:

    our($opt_x, $opt_y);

For those of you who don't like additional global variables being created,
C<getopt()> and C<getopts()> will also accept a hash reference as an optional
second argument.  Hash keys will be C<x> (where C<x> is the switch name) with
key values the value of the argument or C<1> if no argument is specified.

To allow programs to process arguments that look like switches, but aren't,
both functions will stop processing switches when they see the argument
C<-->.  The C<--> will be removed from @ARGV.

=head1 C<--help> and C<--version>

If C<-> is not a recognized switch letter, getopts() supports arguments
C<--help> and C<--version>.  If C<main::HELP_MESSAGE()> and/or
C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are
the output file handle, the name of option-processing package, its version,
and the switches string.  If the subroutines are not defined, an attempt is
made to generate intelligent messages; for best results, define $main::VERSION.

If embedded documentation (in pod format, see L<perlpod>) is detected
in the script, C<--help> will also show how to access the documentation.

Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION
isn't true (the default is false), then the messages are printed on STDERR,
and the processing continues after the messages are printed.  This being
the opposite of the standard-conforming behaviour, it is strongly recommended
to set $Getopt::Std::STANDARD_HELP_VERSION to true.

One can change the output file handle of the messages by setting
$Getopt::Std::OUTPUT_HELP_VERSION.  One can print the messages of C<--help>
(without the C<Usage:> line) and C<--version> by calling functions help_mess()
and version_mess() with the switches string as an argument.

=cut

@ISA = qw(Exporter);
@EXPORT = qw(getopt getopts);
$VERSION = '1.12';
# uncomment the next line to disable 1.03-backward compatibility paranoia
# $STANDARD_HELP_VERSION = 1;

# Process single-character switches with switch clustering.  Pass one argument
# which is a string containing all switches that take an argument.  For each
# switch found, sets $opt_x (where x is the switch name) to the value of the
# argument, or 1 if no argument.  Switches which take an argument don't care
# whether there is a space between the switch and the argument.

# Usage:
#	getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.

sub getopt (;$$) {
    my ($argumentative, $hash) = @_;
    $argumentative = '' if !defined $argumentative;
    my ($first,$rest);
    local $_;
    local @EXPORT;

    while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
	($first,$rest) = ($1,$2);
	if (/^--$/) {	# early exit if --
	    shift @ARGV;
	    last;
	}
	if (index($argumentative,$first) >= 0) {
	    if ($rest ne '') {
		shift(@ARGV);
	    }
	    else {
		shift(@ARGV);
		$rest = shift(@ARGV);
	    }
	    if (ref $hash) {
	        $$hash{$first} = $rest;
	    }
	    else {
	        ${"opt_$first"} = $rest;
	        push( @EXPORT, "\$opt_$first" );
	    }
	}
	else {
	    if (ref $hash) {
	        $$hash{$first} = 1;
	    }
	    else {
	        ${"opt_$first"} = 1;
	        push( @EXPORT, "\$opt_$first" );
	    }
	    if ($rest ne '') {
		$ARGV[0] = "-$rest";
	    }
	    else {
		shift(@ARGV);
	    }
	}
    }
    unless (ref $hash) { 
	local $Exporter::ExportLevel = 1;
	import Getopt::Std;
    }
}

sub output_h () {
  return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION;
  return \*STDOUT if $STANDARD_HELP_VERSION;
  return \*STDERR;
}

sub try_exit () {
    exit 0 if $STANDARD_HELP_VERSION;
    my $p = __PACKAGE__;
    print {output_h()} <<EOM;
  [Now continuing due to backward compatibility and excessive paranoia.
   See 'perldoc $p' about \$$p\::STANDARD_HELP_VERSION.]
EOM
}

sub version_mess ($;$) {
    my $args = shift;
    my $h = output_h;
    if (@_ and defined &main::VERSION_MESSAGE) {
	main::VERSION_MESSAGE($h, __PACKAGE__, $VERSION, $args);
    } else {
	my $v = $main::VERSION;
	$v = '[unknown]' unless defined $v;
	my $myv = $VERSION;
	$myv .= ' [paranoid]' unless $STANDARD_HELP_VERSION;
	my $perlv = $];
	$perlv = sprintf "%vd", $^V if $] >= 5.006;
	print $h <<EOH;
$0 version $v calling Getopt::Std::getopts (version $myv),
running under Perl version $perlv.
EOH
    }
}

sub help_mess ($;$) {
    my $args = shift;
    my $h = output_h;
    if (@_ and defined &main::HELP_MESSAGE) {
	main::HELP_MESSAGE($h, __PACKAGE__, $VERSION, $args);
    } else {
	my (@witharg) = ($args =~ /(\S)\s*:/g);
	my (@rest) = ($args =~ /([^\s:])(?!\s*:)/g);
	my ($help, $arg) = ('', '');
	if (@witharg) {
	    $help .= "\n\tWith arguments: -" . join " -", @witharg;
	    $arg = "\nSpace is not required between options and their arguments.";
	}
	if (@rest) {
	    $help .= "\n\tBoolean (without arguments): -" . join " -", @rest;
	}
	my ($scr) = ($0 =~ m,([^/\\]+)$,);
	print $h <<EOH if @_;			# Let the script override this

Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...]
EOH
	print $h <<EOH;

The following single-character options are accepted:$help

Options may be merged together.  -- stops processing of options.$arg
EOH
	my $has_pod;
	if ( defined $0 and $0 ne '-e' and -f $0 and -r $0
	     and open my $script, '<', $0 ) {
	    while (<$script>) {
		$has_pod = 1, last if /^=(pod|head1)/;
	    }
	}
	print $h <<EOH if $has_pod;

For more details run
	perldoc -F $0
EOH
    }
}

# Usage:
#   getopts('a:bc');	# -a takes arg. -b & -c not. Sets opt_* as a
#			#  side effect.

sub getopts ($;$) {
    my ($argumentative, $hash) = @_;
    my (@args,$first,$rest,$exit);
    my $errs = 0;
    local $_;
    local @EXPORT;

    @args = split( / */, $argumentative );
    while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) {
	($first,$rest) = ($1,$2);
	if (/^--$/) {	# early exit if --
	    shift @ARGV;
	    last;
	}
	my $pos = index($argumentative,$first);
	if ($pos >= 0) {
	    if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
		shift(@ARGV);
		if ($rest eq '') {
		    ++$errs unless @ARGV;
		    $rest = shift(@ARGV);
		}
		if (ref $hash) {
		    $$hash{$first} = $rest;
		}
		else {
		    ${"opt_$first"} = $rest;
		    push( @EXPORT, "\$opt_$first" );
		}
	    }
	    else {
		if (ref $hash) {
		    $$hash{$first} = 1;
		}
		else {
		    ${"opt_$first"} = 1;
		    push( @EXPORT, "\$opt_$first" );
		}
		if ($rest eq '') {
		    shift(@ARGV);
		}
		else {
		    $ARGV[0] = "-$rest";
		}
	    }
	}
	else {
	    if ($first eq '-' and $rest eq 'help') {
		version_mess($argumentative, 'main');
		help_mess($argumentative, 'main');
		try_exit();
		shift(@ARGV);
		next;
	    } elsif ($first eq '-' and $rest eq 'version') {
		version_mess($argumentative, 'main');
		try_exit();
		shift(@ARGV);
		next;
	    }
	    warn "Unknown option: $first\n";
	    ++$errs;
	    if ($rest ne '') {
		$ARGV[0] = "-$rest";
	    }
	    else {
		shift(@ARGV);
	    }
	}
    }
    unless (ref $hash) { 
	local $Exporter::ExportLevel = 1;
	import Getopt::Std;
    }
    $errs == 0;
}

1;