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

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

=head1 NAME

getopt - Process single-character switches with switch clustering

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.

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.

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.04';
# 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
    }
}

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