[p5sagit/p5-mst-13.2.git] / lib / Getopt / Std.pm

package Getopt::Std;
require 5.000;
require Exporter;

=head1 NAME

getopt, getopts - Process single-character switches with switch clustering

=head1 SYNOPSIS

    use Getopt::Std;

    getopt('oDI');    # -o, -D & -I take arg.  Sets $opt_* as a side effect.
    getopt('oDI', \%opts);    # -o, -D & -I take arg.  Values in %opts
    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

=head1 DESCRIPTION

The getopt() function processes 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 if an argument is expected,
or 1 otherwise.  Switches which take an argument don't care whether
there is a space between the switch and the argument.

The getopts() function is similar, but you should pass to it the list of all
switches to be recognized.  If unspecified switches are found on the
command-line, the user will be warned that an unknown option was given.
The getopts() function returns true unless an invalid option was found.

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

    our($opt_x, $opt_y);

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