[p5sagit/p5-mst-13.2.git] / lib / newgetopt.pl

# newgetopt.pl -- new options parsing

# SCCS Status     : @(#)@ newgetopt.pl	1.13
# Author          : Johan Vromans
# Created On      : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
# Last Modified On: Tue Jun  2 11:24:03 1992
# Update Count    : 75
# Status          : Okay

# This package implements a new getopt function. This function adheres
# to the new syntax (long option names, no bundling).
#
# Arguments to the function are:
#
#  - a list of possible options. These should designate valid perl
#    identifiers, optionally followed by an argument specifier ("="
#    for mandatory arguments or ":" for optional arguments) and an
#    argument type specifier: "n" or "i" for integer numbers, "f" for
#    real (fix) numbers or "s" for strings.
#    If an "@" sign is appended, the option is treated as an array.
#    Value(s) are not set, but pushed.
#
#  - if the first option of the list consists of non-alphanumeric
#    characters only, it is interpreted as a generic option starter.
#    Everything starting with one of the characters from the starter
#    will be considered an option.
#    Likewise, a double occurrence (e.g. "--") signals end of
#    the options list.
#    The default value for the starter is "-", "--" or "+".
#
# Upon return, the option variables, prefixed with "opt_", are defined
# and set to the respective option arguments, if any.
# Options that do not take an argument are set to 1. Note that an
# option with an optional argument will be defined, but set to '' if
# no actual argument has been supplied.
# A return status of 0 (false) indicates that the function detected
# one or more errors.
#
# Special care is taken to give a correct treatment to optional arguments.
#
# E.g. if option "one:i" (i.e. takes an optional integer argument),
# then the following situations are handled:
#
#    -one -two		-> $opt_one = '', -two is next option
#    -one -2		-> $opt_one = -2
#
# Also, assume "foo=s" and "bar:s" :
#
#    -bar -xxx		-> $opt_bar = '', '-xxx' is next option
#    -foo -bar		-> $opt_foo = '-bar'
#    -foo --		-> $opt_foo = '--'
#
# HISTORY 
# 2-Jun-1992		Johan Vromans	
#    Do not use //o to allow multiple NGetOpt calls with different delimeters.
#    Prevent typeless option from using previous $array state.
#    Prevent empty option from being eaten as a (negative) number.

# 25-May-1992		Johan Vromans	
#    Add array options. "foo=s@" will return an array @opt_foo that
#    contains all values that were supplied. E.g. "-foo one -foo -two" will
#    return @opt_foo = ("one", "-two");
#    Correct bug in handling options that allow for a argument when followed
#    by another option.

# 4-May-1992		Johan Vromans	
#    Add $ignorecase to match options in either case.
#    Allow '' option.

# 19-Mar-1992		Johan Vromans	
#    Allow require from packages.
#    NGetOpt is now defined in the package that requires it.
#    @ARGV and $opt_... are taken from the package that calls it.
#    Use standard (?) option prefixes: -, -- and +.

# 20-Sep-1990		Johan Vromans	
#    Set options w/o argument to 1.
#    Correct the dreadful semicolon/require bug.


{   package newgetopt;
    $debug = 0;			# for debugging
    $ignorecase = 1;		# ignore case when matching options
}

sub NGetOpt {

    @newgetopt'optionlist = @_;
    *newgetopt'ARGV = *ARGV;

    package newgetopt;

    local ($[) = 0;
    local ($genprefix) = "(--|-|\\+)";
    local ($argend) = "--";
    local ($error) = 0;
    local ($opt, $optx, $arg, $type, $mand, %opctl);
    local ($pkg) = (caller)[0];

    print STDERR "NGetOpt 1.13 -- called from $pkg\n" if $debug;

    # See if the first element of the optionlist contains option
    # starter characters.
    if ( $optionlist[0] =~ /^\W+$/ ) {
	$genprefix = shift (@optionlist);
	# Turn into regexp.
	$genprefix =~ s/(\W)/\\\1/g;
	$genprefix = "[" . $genprefix . "]";
	undef $argend;
    }

    # Verify correctness of optionlist.
    %opctl = ();
    foreach $opt ( @optionlist ) {
	$opt =~ tr/A-Z/a-z/ if $ignorecase;
	if ( $opt !~ /^(\w*)([=:][infse]@?)?$/ ) {
	    print STDERR ("Error in option spec: \"", $opt, "\"\n");
	    $error++;
	    next;
	}
	$opctl{$1} = defined $2 ? $2 : "";
    }

    return 0 if $error;

    if ( $debug ) {
	local ($arrow, $k, $v);
	$arrow = "=> ";
	while ( ($k,$v) = each(%opctl) ) {
	    print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
	    $arrow = "   ";
	}
    }

    # Process argument list

    while ( $#ARGV >= 0 ) {

	# >>> See also the continue block <<<

	# Get next argument
	$opt = shift (@ARGV);
	print STDERR ("=> option \"", $opt, "\"\n") if $debug;
	$arg = undef;

	# Check for exhausted list.
	if ( $opt =~ /^$genprefix/ ) {
	    # Double occurrence is terminator
	    return ($error == 0) 
		if ($opt eq "$+$+") || ((defined $argend) && $opt eq $argend);
	    $opt = $';		# option name (w/o prefix)
	}
	else {
	    # Apparently not an option - push back and exit.
	    unshift (@ARGV, $opt);
	    return ($error == 0);
	}

	# Look it up.
	$opt =~ tr/A-Z/a-z/ if $ignorecase;
	unless  ( defined ( $type = $opctl{$opt} ) ) {
	    print STDERR ("Unknown option: ", $opt, "\n");
	    $error++;
	    next;
	}

	# Determine argument status.
	print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;

	# If it is an option w/o argument, we're almost finished with it.
	if ( $type eq "" ) {
	    $arg = 1;		# supply explicit value
	    $array = 0;
	    next;
	}

	# Get mandatory status and type info.
	($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;

	# Check if the argument list is exhausted.
	if ( $#ARGV < 0 ) {

	    # Complain if this option needs an argument.
	    if ( $mand eq "=" ) {
		print STDERR ("Option ", $opt, " requires an argument\n");
		$error++;
	    }
	    if ( $mand eq ":" ) {
		$arg = $type eq "s" ? "" : 0;
	    }
	    next;
	}

	# Get (possibly optional) argument.
	$arg = shift (@ARGV);

	# Check if it is a valid argument. A mandatory string takes
	# anything. 
	if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/ ) {

	    # Check for option list terminator.
	    if ( $arg eq "$+$+" || 
		 ((defined $argend) && $arg eq $argend)) {
		# Push back so the outer loop will terminate.
		unshift (@ARGV, $arg);
		# Complain if an argument is required.
		if ($mand eq "=") {
		    print STDERR ("Option ", $opt, " requires an argument\n");
		    $error++;
		    undef $arg;	# don't assign it
		}
		else {
		    # Supply empty value.
		    $arg = $type eq "s" ? "" : 0;
		}
		next;
	    }

	    # Maybe the optional argument is the next option?
	    if ( $mand eq ":" && ($' eq "" || $' =~ /[a-zA-Z_]/) ) {
		# Yep. Push back.
		unshift (@ARGV, $arg);
		$arg = $type eq "s" ? "" : 0;
		next;
	    }
	}

	if ( $type eq "n" || $type eq "i" ) { # numeric/integer
	    if ( $arg !~ /^-?[0-9]+$/ ) {
		print STDERR ("Value \"", $arg, "\" invalid for option ",
			      $opt, " (number expected)\n");
		$error++;
		undef $arg;	# don't assign it
	    }
	    next;
	}

	if ( $type eq "f" ) { # fixed real number, int is also ok
	    if ( $arg !~ /^-?[0-9.]+$/ ) {
		print STDERR ("Value \"", $arg, "\" invalid for option ",
			      $opt, " (real number expected)\n");
		$error++;
		undef $arg;	# don't assign it
	    }
	    next;
	}

	if ( $type eq "s" ) { # string
	    next;
	}

    }
    continue {
	if ( defined $arg ) {
	    if ( $array ) {
		print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
		    if $debug;
	        eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
	    }
	    else {
		print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
		    if $debug;
	        eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
	    }
	}
    }

    return ($error == 0);
}
1;
Commit	Line	Data
352d5a3a	1	# newgetopt.pl -- new options parsing
352d5a3a	2
ee0007ab	3	# SCCS Status : @(#)@ newgetopt.pl 1.13
352d5a3a	4	# Author : Johan Vromans
	5	# Created On : Tue Sep 11 15:00:12 1990
	6	# Last Modified By: Johan Vromans
ee0007ab	7	# Last Modified On: Tue Jun 2 11:24:03 1992
ee0007ab	8	# Update Count : 75
352d5a3a	9	# Status : Okay
	10
	11	# This package implements a new getopt function. This function adheres
	12	# to the new syntax (long option names, no bundling).
	13	#
	14	# Arguments to the function are:
	15	#
	16	# - a list of possible options. These should designate valid perl
	17	# identifiers, optionally followed by an argument specifier ("="
	18	# for mandatory arguments or ":" for optional arguments) and an
	19	# argument type specifier: "n" or "i" for integer numbers, "f" for
	20	# real (fix) numbers or "s" for strings.
ee0007ab	21	# If an "@" sign is appended, the option is treated as an array.
ee0007ab	22	# Value(s) are not set, but pushed.
352d5a3a	23	#
	24	# - if the first option of the list consists of non-alphanumeric
	25	# characters only, it is interpreted as a generic option starter.
	26	# Everything starting with one of the characters from the starter
	27	# will be considered an option.
	28	# Likewise, a double occurrence (e.g. "--") signals end of
	29	# the options list.
ee0007ab	30	# The default value for the starter is "-", "--" or "+".
352d5a3a	31	#
	32	# Upon return, the option variables, prefixed with "opt_", are defined
	33	# and set to the respective option arguments, if any.
	34	# Options that do not take an argument are set to 1. Note that an
	35	# option with an optional argument will be defined, but set to '' if
	36	# no actual argument has been supplied.
	37	# A return status of 0 (false) indicates that the function detected
	38	# one or more errors.
	39	#
	40	# Special care is taken to give a correct treatment to optional arguments.
	41	#
	42	# E.g. if option "one:i" (i.e. takes an optional integer argument),
	43	# then the following situations are handled:
	44	#
	45	# -one -two -> $opt_one = '', -two is next option
	46	# -one -2 -> $opt_one = -2
	47	#
	48	# Also, assume "foo=s" and "bar:s" :
	49	#
	50	# -bar -xxx -> $opt_bar = '', '-xxx' is next option
	51	# -foo -bar -> $opt_foo = '-bar'
	52	# -foo -- -> $opt_foo = '--'
	53	#
352d5a3a	54	# HISTORY
ee0007ab	55	# 2-Jun-1992 Johan Vromans
	56	# Do not use //o to allow multiple NGetOpt calls with different delimeters.
	57	# Prevent typeless option from using previous $array state.
	58	# Prevent empty option from being eaten as a (negative) number.
	59
	60	# 25-May-1992 Johan Vromans
	61	# Add array options. "foo=s@" will return an array @opt_foo that
	62	# contains all values that were supplied. E.g. "-foo one -foo -two" will
	63	# return @opt_foo = ("one", "-two");
	64	# Correct bug in handling options that allow for a argument when followed
	65	# by another option.
	66
	67	# 4-May-1992 Johan Vromans
	68	# Add $ignorecase to match options in either case.
	69	# Allow '' option.
	70
	71	# 19-Mar-1992 Johan Vromans
	72	# Allow require from packages.
	73	# NGetOpt is now defined in the package that requires it.
	74	# @ARGV and $opt_... are taken from the package that calls it.
	75	# Use standard (?) option prefixes: -, -- and +.
	76
352d5a3a	77	# 20-Sep-1990 Johan Vromans
	78	# Set options w/o argument to 1.
	79	# Correct the dreadful semicolon/require bug.
	80
	81
ee0007ab	82	{ package newgetopt;
	83	$debug = 0; # for debugging
	84	$ignorecase = 1; # ignore case when matching options
	85	}
	86
	87	sub NGetOpt {
	88
	89	@newgetopt'optionlist = @_;
	90	newgetopt'ARGV = ARGV;
352d5a3a	91
ee0007ab	92	package newgetopt;
352d5a3a	93
352d5a3a	94	local ($[) = 0;
ee0007ab	95	local ($genprefix) = "(--\|-\|\\+)";
ee0007ab	96	local ($argend) = "--";
352d5a3a	97	local ($error) = 0;
ee0007ab	98	local ($opt, $optx, $arg, $type, $mand, %opctl);
	99	local ($pkg) = (caller)[0];
	100
	101	print STDERR "NGetOpt 1.13 -- called from $pkg\n" if $debug;
352d5a3a	102
	103	# See if the first element of the optionlist contains option
	104	# starter characters.
ee0007ab	105	if ( $optionlist[0] =~ /^\W+$/ ) {
	106	$genprefix = shift (@optionlist);
	107	# Turn into regexp.
	108	$genprefix =~ s/(\W)/\\\1/g;
	109	$genprefix = "[" . $genprefix . "]";
	110	undef $argend;
	111	}
352d5a3a	112
352d5a3a	113	# Verify correctness of optionlist.
ee0007ab	114	%opctl = ();
	115	foreach $opt ( @optionlist ) {
	116	$opt =~ tr/A-Z/a-z/ if $ignorecase;
	117	if ( $opt !~ /^(\w*)([=:][infse]@?)?$/ ) {
352d5a3a	118	print STDERR ("Error in option spec: \"", $opt, "\"\n");
352d5a3a	119	$error++;
ee0007ab	120	next;
	121	}
	122	$opctl{$1} = defined $2 ? $2 : "";
	123	}
	124
	125	return 0 if $error;
	126
	127	if ( $debug ) {
	128	local ($arrow, $k, $v);
	129	$arrow = "=> ";
	130	while ( ($k,$v) = each(%opctl) ) {
	131	print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
	132	$arrow = " ";
352d5a3a	133	}
352d5a3a	134	}
	135
	136	# Process argument list
	137
ee0007ab	138	while ( $#ARGV >= 0 ) {
352d5a3a	139
	140	# >>> See also the continue block <<<
	141
	142	# Get next argument
ee0007ab	143	$opt = shift (@ARGV);
352d5a3a	144	print STDERR ("=> option \"", $opt, "\"\n") if $debug;
	145	$arg = undef;
	146
	147	# Check for exhausted list.
ee0007ab	148	if ( $opt =~ /^$genprefix/ ) {
352d5a3a	149	# Double occurrence is terminator
ee0007ab	150	return ($error == 0)
ee0007ab	151	if ($opt eq "$+$+") \|\| ((defined $argend) && $opt eq $argend);
352d5a3a	152	$opt = $'; # option name (w/o prefix)
	153	}
	154	else {
	155	# Apparently not an option - push back and exit.
ee0007ab	156	unshift (@ARGV, $opt);
352d5a3a	157	return ($error == 0);
	158	}
	159
ee0007ab	160	# Look it up.
	161	$opt =~ tr/A-Z/a-z/ if $ignorecase;
	162	unless ( defined ( $type = $opctl{$opt} ) ) {
352d5a3a	163	print STDERR ("Unknown option: ", $opt, "\n");
	164	$error++;
	165	next;
	166	}
	167
	168	# Determine argument status.
ee0007ab	169	print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
352d5a3a	170
352d5a3a	171	# If it is an option w/o argument, we're almost finished with it.
ee0007ab	172	if ( $type eq "" ) {
352d5a3a	173	$arg = 1; # supply explicit value
ee0007ab	174	$array = 0;
352d5a3a	175	next;
	176	}
	177
	178	# Get mandatory status and type info.
ee0007ab	179	($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
352d5a3a	180
352d5a3a	181	# Check if the argument list is exhausted.
ee0007ab	182	if ( $#ARGV < 0 ) {
352d5a3a	183
	184	# Complain if this option needs an argument.
	185	if ( $mand eq "=" ) {
	186	print STDERR ("Option ", $opt, " requires an argument\n");
	187	$error++;
	188	}
45d8adaa	189	if ( $mand eq ":" ) {
	190	$arg = $type eq "s" ? "" : 0;
	191	}
352d5a3a	192	next;
	193	}
	194
	195	# Get (possibly optional) argument.
ee0007ab	196	$arg = shift (@ARGV);
352d5a3a	197
352d5a3a	198	# Check if it is a valid argument. A mandatory string takes
ee0007ab	199	# anything.
ee0007ab	200	if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/ ) {
352d5a3a	201
352d5a3a	202	# Check for option list terminator.
ee0007ab	203	if ( $arg eq "$+$+" \|\|
	204	((defined $argend) && $arg eq $argend)) {
	205	# Push back so the outer loop will terminate.
	206	unshift (@ARGV, $arg);
352d5a3a	207	# Complain if an argument is required.
	208	if ($mand eq "=") {
	209	print STDERR ("Option ", $opt, " requires an argument\n");
	210	$error++;
ee0007ab	211	undef $arg; # don't assign it
	212	}
	213	else {
	214	# Supply empty value.
	215	$arg = $type eq "s" ? "" : 0;
352d5a3a	216	}
352d5a3a	217	next;
	218	}
	219
	220	# Maybe the optional argument is the next option?
ee0007ab	221	if ( $mand eq ":" && ($' eq "" \|\| $' =~ /[a-zA-Z_]/) ) {
352d5a3a	222	# Yep. Push back.
ee0007ab	223	unshift (@ARGV, $arg);
ee0007ab	224	$arg = $type eq "s" ? "" : 0;
352d5a3a	225	next;
	226	}
	227	}
	228
	229	if ( $type eq "n" \|\| $type eq "i" ) { # numeric/integer
	230	if ( $arg !~ /^-?[0-9]+$/ ) {
	231	print STDERR ("Value \"", $arg, "\" invalid for option ",
ee0007ab	232	$opt, " (number expected)\n");
352d5a3a	233	$error++;
ee0007ab	234	undef $arg; # don't assign it
352d5a3a	235	}
	236	next;
	237	}
	238
	239	if ( $type eq "f" ) { # fixed real number, int is also ok
	240	if ( $arg !~ /^-?[0-9.]+$/ ) {
	241	print STDERR ("Value \"", $arg, "\" invalid for option ",
ee0007ab	242	$opt, " (real number expected)\n");
352d5a3a	243	$error++;
ee0007ab	244	undef $arg; # don't assign it
352d5a3a	245	}
	246	next;
	247	}
	248
	249	if ( $type eq "s" ) { # string
	250	next;
	251	}
	252
	253	}
	254	continue {
ee0007ab	255	if ( defined $arg ) {
	256	if ( $array ) {
	257	print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
	258	if $debug;
	259	eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
	260	}
	261	else {
	262	print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
	263	if $debug;
	264	eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
	265	}
	266	}
352d5a3a	267	}
	268
	269	return ($error == 0);
	270	}
	271	1;