[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.

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.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
	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
	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
669ecdbc	58	If embedded documentation (in pod format, see L<perlpod>) is detected
	59	in the script, C<--help> will also show how to access the documentation.
	60
294d099e	61	Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION
	62	isn't true (the default is false), then the messages are printed on STDERR,
	63	and the processing continues after the messages are printed. This being
	64	the opposite of the standard-conforming behaviour, it is strongly recommended
	65	to set $Getopt::Std::STANDARD_HELP_VERSION to true.
	66
	67	One can change the output file handle of the messages by setting
	68	$Getopt::Std::OUTPUT_HELP_VERSION. One can print the messages of C<--help>
	69	(without the C<Usage:> line) and C<--version> by calling functions help_mess()
	70	and version_mess() with the switches string as an argument.
	71
f06db76b	72	=cut
f06db76b	73
a0d0e21e	74	@ISA = qw(Exporter);
a0d0e21e	75	@EXPORT = qw(getopt getopts);
294d099e	76	$VERSION = '1.04';
	77	# uncomment the next line to disable 1.03-backward compatibility paranoia
	78	# $STANDARD_HELP_VERSION = 1;
a0d0e21e	79
	80	# Process single-character switches with switch clustering. Pass one argument
	81	# which is a string containing all switches that take an argument. For each
	82	# switch found, sets $opt_x (where x is the switch name) to the value of the
	83	# argument, or 1 if no argument. Switches which take an argument don't care
	84	# whether there is a space between the switch and the argument.
	85
	86	# Usage:
	87	# getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
	88
12527e6c	89	sub getopt (;$$) {
	90	my ($argumentative, $hash) = @_;
	91	$argumentative = '' if !defined $argumentative;
	92	my ($first,$rest);
	93	local $_;
6ca64377	94	local @EXPORT;
a0d0e21e	95
	96	while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
	97	($first,$rest) = ($1,$2);
5812d790	98	if (/^--$/) { # early exit if --
	99	shift @ARGV;
	100	last;
	101	}
a0d0e21e	102	if (index($argumentative,$first) >= 0) {
	103	if ($rest ne '') {
	104	shift(@ARGV);
	105	}
	106	else {
	107	shift(@ARGV);
	108	$rest = shift(@ARGV);
	109	}
5812d790	110	if (ref $hash) {
	111	$$hash{$first} = $rest;
	112	}
	113	else {
	114	${"opt_$first"} = $rest;
	115	push( @EXPORT, "\$opt_$first" );
	116	}
a0d0e21e	117	}
a0d0e21e	118	else {
5812d790	119	if (ref $hash) {
	120	$$hash{$first} = 1;
	121	}
	122	else {
	123	${"opt_$first"} = 1;
	124	push( @EXPORT, "\$opt_$first" );
	125	}
a0d0e21e	126	if ($rest ne '') {
	127	$ARGV[0] = "-$rest";
	128	}
	129	else {
	130	shift(@ARGV);
	131	}
	132	}
	133	}
6ca64377	134	unless (ref $hash) {
	135	local $Exporter::ExportLevel = 1;
	136	import Getopt::Std;
	137	}
a0d0e21e	138	}
a0d0e21e	139
294d099e	140	sub output_h () {
	141	return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION;
	142	return \*STDOUT if $STANDARD_HELP_VERSION;
	143	return \*STDERR;
	144	}
	145
	146	sub try_exit () {
	147	exit 0 if $STANDARD_HELP_VERSION;
	148	my $p = __PACKAGE__;
	149	print {output_h()} <<EOM;
	150	[Now continuing due to backward compatibility and excessive paranoia.
	151	See ``perldoc $p'' about \$$p\::STANDARD_HELP_VERSION.]
	152	EOM
	153	}
	154
	155	sub version_mess ($;$) {
	156	my $args = shift;
	157	my $h = output_h;
	158	if (@_ and defined &main::VERSION_MESSAGE) {
	159	main::VERSION_MESSAGE($h, __PACKAGE__, $VERSION, $args);
	160	} else {
	161	my $v = $main::VERSION;
	162	$v = '[unknown]' unless defined $v;
	163	my $myv = $VERSION;
	164	$myv .= ' [paranoid]' unless $STANDARD_HELP_VERSION;
	165	my $perlv = $];
	166	$perlv = sprintf "%vd", $^V if $] >= 5.006;
	167	print $h <<EOH;
	168	$0 version $v calling Getopt::Std::getopts (version $myv),
	169	running under Perl version $perlv.
	170	EOH
	171	}
	172	}
	173
	174	sub help_mess ($;$) {
	175	my $args = shift;
	176	my $h = output_h;
	177	if (@_ and defined &main::HELP_MESSAGE) {
	178	main::HELP_MESSAGE($h, __PACKAGE__, $VERSION, $args);
	179	} else {
	180	my (@witharg) = ($args =~ /(\S)\s*:/g);
	181	my (@rest) = ($args =~ /([^\s:])(?!\s*:)/g);
	182	my ($help, $arg) = ('', '');
	183	if (@witharg) {
	184	$help .= "\n\tWith arguments: -" . join " -", @witharg;
	185	$arg = "\nSpace is not required between options and their arguments.";
	186	}
	187	if (@rest) {
	188	$help .= "\n\tBoolean (without arguments): -" . join " -", @rest;
	189	}
	190	my ($scr) = ($0 =~ m,([^/\\]+)$,);
	191	print $h <<EOH if @_; # Let the script override this
669ecdbc	192
294d099e	193	Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...]
	194	EOH
	195	print $h <<EOH;
669ecdbc	196
294d099e	197	The following single-character options are accepted:$help
669ecdbc	198
294d099e	199	Options may be merged together. -- stops processing of options.$arg
294d099e	200	EOH
669ecdbc	201	my $has_pod;
	202	if ( defined $0 and $0 ne '-e' and -f $0 and -r $0
	203	and open my $script, '<', $0 ) {
	204	while (<$script>) {
	205	$has_pod = 1, last if /^=(pod\|head1)/;
	206	}
	207	}
	208	print $h <<EOH if $has_pod;
	209
	210	For more details run
	211	perldoc -F $0
	212	EOH
294d099e	213	}
	214	}
	215
a0d0e21e	216	# Usage:
	217	# getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
	218	# # side effect.
	219
0bc14741	220	sub getopts ($;$) {
12527e6c	221	my ($argumentative, $hash) = @_;
294d099e	222	my (@args,$first,$rest,$exit);
12527e6c	223	my $errs = 0;
12527e6c	224	local $_;
6ca64377	225	local @EXPORT;
a0d0e21e	226
a0d0e21e	227	@args = split( / */, $argumentative );
294d099e	228	while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) {
a0d0e21e	229	($first,$rest) = ($1,$2);
5812d790	230	if (/^--$/) { # early exit if --
	231	shift @ARGV;
	232	last;
	233	}
294d099e	234	my $pos = index($argumentative,$first);
5812d790	235	if ($pos >= 0) {
5812d790	236	if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
a0d0e21e	237	shift(@ARGV);
5812d790	238	if ($rest eq '') {
a0d0e21e	239	++$errs unless @ARGV;
	240	$rest = shift(@ARGV);
	241	}
5812d790	242	if (ref $hash) {
	243	$$hash{$first} = $rest;
	244	}
	245	else {
	246	${"opt_$first"} = $rest;
	247	push( @EXPORT, "\$opt_$first" );
	248	}
a0d0e21e	249	}
a0d0e21e	250	else {
5812d790	251	if (ref $hash) {
	252	$$hash{$first} = 1;
	253	}
	254	else {
	255	${"opt_$first"} = 1;
	256	push( @EXPORT, "\$opt_$first" );
	257	}
	258	if ($rest eq '') {
a0d0e21e	259	shift(@ARGV);
	260	}
	261	else {
	262	$ARGV[0] = "-$rest";
	263	}
	264	}
	265	}
	266	else {
294d099e	267	if ($first eq '-' and $rest eq 'help') {
	268	version_mess($argumentative, 'main');
	269	help_mess($argumentative, 'main');
	270	try_exit();
	271	shift(@ARGV);
	272	next;
	273	} elsif ($first eq '-' and $rest eq 'version') {
	274	version_mess($argumentative, 'main');
	275	try_exit();
	276	shift(@ARGV);
	277	next;
	278	}
55118cb0	279	warn "Unknown option: $first\n";
a0d0e21e	280	++$errs;
5812d790	281	if ($rest ne '') {
a0d0e21e	282	$ARGV[0] = "-$rest";
	283	}
	284	else {
	285	shift(@ARGV);
	286	}
	287	}
	288	}
6ca64377	289	unless (ref $hash) {
	290	local $Exporter::ExportLevel = 1;
	291	import Getopt::Std;
	292	}
a0d0e21e	293	$errs == 0;
	294	}
	295
	296	1;