[perl5.git] / lib / Getopt / Long.pm

package Getopt::Long;
require 5.000;
require Exporter;

@ISA = qw(Exporter);
@EXPORT = qw(GetOptions);


# newgetopt.pl -- new options parsing

# SCCS Status     : @(#)@ newgetopt.pl	1.14
# Author          : Johan Vromans
# Created On      : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
# Last Modified On: Sat Feb 12 18:24:02 1994
# Update Count    : 138
# Status          : Okay

################ Introduction ################
#
# This package implements an extended getopt function. This function adheres
# to the new syntax (long option names, no bundling).
# It tries to implement the better functionality of traditional, GNU and
# POSIX getopt functions.
# 
# This program is Copyright 1990,1994 by Johan Vromans.
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# If you do not have a copy of the GNU General Public License write to
# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
# MA 02139, USA.

################ Description ################
#
# Usage:
# 
#    require "newgetopt.pl";
#    ...change configuration values, if needed...
#    $result = &NGetOpt (...option-descriptions...);
# 
# Each description should designate a valid perl identifier, optionally
# followed by an argument specifier.
# 
# Values for argument specifiers are:
# 
#   <none>   option does not take an argument
#   !        option does not take an argument and may be negated
#   =s :s    option takes a mandatory (=) or optional (:) string argument
#   =i :i    option takes a mandatory (=) or optional (:) integer argument
#   =f :f    option takes a mandatory (=) or optional (:) real number argument
# 
# If option "name" is set, it will cause the perl variable $opt_name to
# be set to the specified value. The calling program can use this
# variable to detect whether the option has been set. Options that do
# not take an argument will be set to 1 (one).
# 
# Options that take an optional argument will be defined, but set to ''
# if no actual argument has been supplied.
# 
# If an "@" sign is appended to the argument specifier, the option is
# treated as an array. Value(s) are not set, but pushed into array
# @opt_name.
# 
# Options that do not take a value may have an "!" argument spacifier to
# indicate that they may be negated. E.g. "foo!" will allow -foo (which
# sets $opt_foo to 1) and -nofoo (which will set $opt_foo to 0).
# 
# The option name may actually be a list of option names, separated by
# '|'s, e.g. "foo|bar|blech=s". In this example, options 'bar' and
# 'blech' will set $opt_foo instead.
# 
# Option names may be abbreviated to uniqueness, depending on
# configuration variable $autoabbrev.
# 
# Dashes in option names are allowed (e.g. pcc-struct-return) and will
# be translated to underscores in the corresponding perl variable (e.g.
# $opt_pcc_struct_return).  Note that a lone dash "-" is considered an
# option, corresponding perl identifier is $opt_ .
# 
# A double dash "--" signals end of the options list.
# 
# 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.
# 
# The default values for the option starters are "-" (traditional), "--"
# (POSIX) and "+" (GNU, being phased out).
# 
# Options that start with "--" may have an argument appended, separated
# with an "=", e.g. "--foo=bar".
# 
# If configuration varaible $getopt_compat is set to a non-zero value,
# options that start with "+" may also include their arguments,
# e.g. "+foo=bar".
# 
# A return status of 0 (false) indicates that the function detected
# one or more errors.
#
################ Some examples ################
# 
# 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 = '--'
# 
# In GNU or POSIX format, option names and values can be combined:
# 
#    +foo=blech		-> $opt_foo = 'blech'
#    --bar=		-> $opt_bar = ''
#    --bar=--		-> $opt_bar = '--'
# 
################ Configuration values ################
# 
#   $autoabbrev      Allow option names to be abbreviated to uniqueness.
#                    Default is 1 unless environment variable
#                    POSIXLY_CORRECT has been set.
# 
#   $getopt_compat   Allow '+' to start options.
#                    Default is 1 unless environment variable
#                    POSIXLY_CORRECT has been set.
# 
#   $option_start    Regexp with option starters.
#                    Default is (--|-) if environment variable
#                    POSIXLY_CORRECT has been set, (--|-|\+) otherwise.
# 
#   $order           Whether non-options are allowed to be mixed with
#                    options.
#                    Default is $REQUIRE_ORDER if environment variable
#                    POSIXLY_CORRECT has been set, $PERMUTE otherwise.
# 
#   $ignorecase      Ignore case when matching options. Default is 1.
# 
#   $debug           Enable debugging output. Default is 0.

################ History ################
# 
# 12-Feb-1994		Johan Vromans	
#    Added "!" for negation.
#    Released to the net.
#
# 26-Aug-1992		Johan Vromans	
#    More POSIX/GNU compliance.
#    Lone dash and double-dash are now independent of the option prefix
#      that is used.
#    Make errors in NGetOpt parameters fatal.
#    Allow options to be mixed with arguments.
#      Check $ENV{"POSIXLY_CORRECT"} to suppress this.
#    Allow --foo=bar and +foo=bar (but not -foo=bar).
#    Allow options to be abbreviated to minimum needed for uniqueness.
#      (Controlled by configuration variable $autoabbrev.)
#    Allow alias names for options (e.g. "foo|bar=s").
#    Allow "-" in option names (e.g. --pcc-struct-return). Dashes are
#      translated to "_" to form valid perl identifiers
#      (e.g. $opt_pcc_struct_return). 
#
# 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.

################ Configuration Section ################

{ 

    # Values for $order. See GNU getopt.c for details.
    $REQUIRE_ORDER = 0;
    $PERMUTE = 1;
    $RETURN_IN_ORDER = 2;

    # Handle POSIX compliancy.
    if ( defined $ENV{"POSIXLY_CORRECT"} ) {
	$autoabbrev = 0;	# no automatic abbrev of options (???)
	$getopt_compat = 0;	# disallow '+' to start options
	$option_start = "(--|-)";
	$order = $REQUIRE_ORDER;
    }
    else {
	$autoabbrev = 1;	# automatic abbrev of options
	$getopt_compat = 1;	# allow '+' to start options
	$option_start = "(--|-|\\+)";
	$order = $PERMUTE;
    }

    # Other configurable settings.
    $debug = 0;			# for debugging
    $ignorecase = 1;		# ignore case when matching options
    $argv_end = "--";		# don't change this!
}

################ Subroutines ################

sub GetOptions {

    @optionlist = @_;	#';

    local ($[) = 0;
    local ($genprefix) = $option_start;
    local ($argend) = $argv_end;
    local ($error) = 0;
    local ($opt, $optx, $arg, $type, $mand, %opctl);
    local ($pkg) = (caller)[0];
    local ($optarg);
    local (%aliases);
    local (@ret) = ();

    print STDERR "NGetOpt 1.14 -- 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 . "]";
    }

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

	if ( ! defined $o ) {
	    $opctl{''} = defined $c ? $c : '';
	}
	else {
	    # Handle alias names
	    foreach ( split (/\|/, $o)) {
		if ( defined $c && $c eq '!' ) {
		    $opctl{"no$_"} = $c;
		    $c = '';
		}
		$opctl{$_} = defined $c ? $c : '';
		if ( defined $a ) {
		    # Note alias.
		    $aliases{$_} = $a;
		}
		else {
		    # Set primary name.
		    $a = $_;
		}
	    }
	}
    }
    @opctl = sort(keys (%opctl)) if $autoabbrev;

    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;
	$optarg = undef;
	$array = 0;

	#### Determine what we have ####

	# Double dash is option list terminator.
	if ( $opt eq $argend ) {
	    unshift (@ret, @ARGV) if $order == $PERMUTE;
	    return ($error == 0);
	}
	elsif ( $opt =~ /^$genprefix/ ) {
	    # Looks like an option.
	    $opt = $';		# option name (w/o prefix)
	    # If it is a long opt, it may include the value.
	    if (($+ eq "--" || ($getopt_compat && $+ eq "+")) && 
		$opt =~ /^([^=]+)=/ ) {
		$opt = $1;
		$optarg = $';
		print STDERR ("=> option \"", $opt, 
			      "\", optarg = \"$optarg\"\n")
		    if $debug;
	    }

	}
	# Not an option. Save it if we may permute...
	elsif ( $order == $PERMUTE ) {
	    push (@ret, $opt);
	    next;
	}
	# ...otherwise, terminate.
	else {
	    # Push back and exit.
	    unshift (@ARGV, $opt);
	    return ($error == 0);
	}

	#### Look it up ###

	$opt =~ tr/A-Z/a-z/ if $ignorecase;

	local ($tryopt) = $opt;
	if ( $autoabbrev ) {
	    local ($pat, @hits);

	    # Turn option name into pattern.
	    ($pat = $opt) =~ s/(\W)/\\$1/g;
	    # Look up in option names.
	    @hits = grep (/^$pat/, @opctl);
	    print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ",
			  "out of ", 0+@opctl, "\n")
		if $debug;

	    # Check for ambiguous results.
	    unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
		print STDERR ("Option ", $opt, " is ambiguous (",
			      join(", ", @hits), ")\n");
		$error++;
		next;
	    }

	    # Complete the option name, if appropriate.
	    if ( @hits == 1 && $hits[0] ne $opt ) {
		$tryopt = $hits[0];
		print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
		    if $debug;
	    }
	}

	unless  ( defined ( $type = $opctl{$tryopt} ) ) {
	    print STDERR ("Unknown option: ", $opt, "\n");
	    $error++;
	    next;
	}
	$opt = $tryopt;
	print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;

	#### Determine argument status ####

	# If it is an option w/o argument, we're almost finished with it.
	if ( $type eq '' || $type eq '!' ) {
	    if ( defined $optarg ) {
		print STDERR ("Option ", $opt, " does not take an argument\n");
		$error++;
	    }
	    elsif ( $type eq '' ) {
		$arg = 1;		# supply explicit value
	    }
	    else {
		substr ($opt, 0, 2) = ''; # strip NO prefix
		$arg = 0;		# supply explicit value
	    }
	    next;
	}

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

	# Check if there is an option argument available.
	if ( defined $optarg ? ($optarg eq '') : ($#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 = defined $optarg ? $optarg : shift (@ARGV);

	#### Check if the argument is valid for this option ####

	if ( $type eq "s" ) {	# string
	    # A mandatory string takes anything. 
	    next if $mand eq "=";

	    # An optional string takes almost anything. 
	    next if defined $optarg;
	    next if $arg eq "-";

	    # Check for option or option list terminator.
	    if ($arg eq $argend ||
		$arg =~ /^$genprefix.+/) {
		# Push back.
		unshift (@ARGV, $arg);
		# Supply empty value.
		$arg = '';
	    }
	    next;
	}

	if ( $type eq "n" || $type eq "i" ) { # numeric/integer
	    if ( $arg !~ /^-?[0-9]+$/ ) {
		if ( defined $optarg || $mand eq "=" ) {
		    print STDERR ("Value \"", $arg, "\" invalid for option ",
				  $opt, " (number expected)\n");
		    $error++;
		    undef $arg;	# don't assign it
		}
		else {
		    # Push back.
		    unshift (@ARGV, $arg);
		    # Supply default value.
		    $arg = 0;
		}
	    }
	    next;
	}

	if ( $type eq "f" ) { # fixed real number, int is also ok
	    if ( $arg !~ /^-?[0-9.]+$/ ) {
		if ( defined $optarg || $mand eq "=" ) {
		    print STDERR ("Value \"", $arg, "\" invalid for option ",
				  $opt, " (real number expected)\n");
		    $error++;
		    undef $arg;	# don't assign it
		}
		else {
		    # Push back.
		    unshift (@ARGV, $arg);
		    # Supply default value.
		    $arg = 0.0;
		}
	    }
	    next;
	}

	die ("NGetOpt internal error (Can't happen)\n");
    }

    continue {
	if ( defined $arg ) {
	    $opt = $aliases{$opt} if defined $aliases{$opt};
	    # Make sure a valid perl identifier results.
	    $opt =~ s/\W/_/g;
	    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;");
	    }
	}
    }

    if ( $order == $PERMUTE && @ret > 0 ) {
	unshift (@ARGV, @ret);
    }
    return ($error == 0);
}

################ Package return ################

1;
Commit	Line	Data
a0d0e21e LW	1	package Getopt::Long;
	2	require 5.000;
	3	require Exporter;
	4
	5	@ISA = qw(Exporter);
	6	@EXPORT = qw(GetOptions);
	7
	8
	9	# newgetopt.pl -- new options parsing
	10
	11	# SCCS Status : @(#)@ newgetopt.pl 1.14
	12	# Author : Johan Vromans
	13	# Created On : Tue Sep 11 15:00:12 1990
	14	# Last Modified By: Johan Vromans
	15	# Last Modified On: Sat Feb 12 18:24:02 1994
	16	# Update Count : 138
	17	# Status : Okay
	18
	19	################ Introduction ################
	20	#
	21	# This package implements an extended getopt function. This function adheres
	22	# to the new syntax (long option names, no bundling).
	23	# It tries to implement the better functionality of traditional, GNU and
	24	# POSIX getopt functions.
	25	#
	26	# This program is Copyright 1990,1994 by Johan Vromans.
	27	# This program is free software; you can redistribute it and/or
	28	# modify it under the terms of the GNU General Public License
	29	# as published by the Free Software Foundation; either version 2
	30	# of the License, or (at your option) any later version.
	31	#
	32	# This program is distributed in the hope that it will be useful,
	33	# but WITHOUT ANY WARRANTY; without even the implied warranty of
	34	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	35	# GNU General Public License for more details.
	36	#
	37	# If you do not have a copy of the GNU General Public License write to
	38	# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
	39	# MA 02139, USA.
	40
	41	################ Description ################
	42	#
	43	# Usage:
	44	#
	45	# require "newgetopt.pl";
	46	# ...change configuration values, if needed...
	47	# $result = &NGetOpt (...option-descriptions...);
	48	#
	49	# Each description should designate a valid perl identifier, optionally
	50	# followed by an argument specifier.
	51	#
	52	# Values for argument specifiers are:
	53	#
	54	# <none> option does not take an argument
	55	# ! option does not take an argument and may be negated
	56	# =s :s option takes a mandatory (=) or optional (:) string argument
	57	# =i :i option takes a mandatory (=) or optional (:) integer argument
	58	# =f :f option takes a mandatory (=) or optional (:) real number argument
	59	#
	60	# If option "name" is set, it will cause the perl variable $opt_name to
	61	# be set to the specified value. The calling program can use this
	62	# variable to detect whether the option has been set. Options that do
	63	# not take an argument will be set to 1 (one).
	64	#
65	# Options that take an optional argument will be defined, but set to ''
66	# if no actual argument has been supplied.
67	#
68	# If an "@" sign is appended to the argument specifier, the option is
69	# treated as an array. Value(s) are not set, but pushed into array
70	# @opt_name.
71	#
72	# Options that do not take a value may have an "!" argument spacifier to
73	# indicate that they may be negated. E.g. "foo!" will allow -foo (which
74	# sets $opt_foo to 1) and -nofoo (which will set $opt_foo to 0).
75	#
76	# The option name may actually be a list of option names, separated by
77	# '\|'s, e.g. "foo\|bar\|blech=s". In this example, options 'bar' and
78	# 'blech' will set $opt_foo instead.
79	#
80	# Option names may be abbreviated to uniqueness, depending on
81	# configuration variable $autoabbrev.
82	#
83	# Dashes in option names are allowed (e.g. pcc-struct-return) and will
84	# be translated to underscores in the corresponding perl variable (e.g.
85	# $opt_pcc_struct_return). Note that a lone dash "-" is considered an
86	# option, corresponding perl identifier is $opt_ .
87	#
88	# A double dash "--" signals end of the options list.
89	#
90	# If the first option of the list consists of non-alphanumeric
91	# characters only, it is interpreted as a generic option starter.
92	# Everything starting with one of the characters from the starter will
93	# be considered an option.
94	#
95	# The default values for the option starters are "-" (traditional), "--"
96	# (POSIX) and "+" (GNU, being phased out).
97	#
98	# Options that start with "--" may have an argument appended, separated
99	# with an "=", e.g. "--foo=bar".
100	#
101	# If configuration varaible $getopt_compat is set to a non-zero value,
102	# options that start with "+" may also include their arguments,
103	# e.g. "+foo=bar".
104	#
105	# A return status of 0 (false) indicates that the function detected
106	# one or more errors.
107	#
108	################ Some examples ################
109	#
110	# If option "one:i" (i.e. takes an optional integer argument), then
111	# the following situations are handled:
112	#
113	# -one -two -> $opt_one = '', -two is next option
114	# -one -2 -> $opt_one = -2
115	#
116	# Also, assume "foo=s" and "bar:s" :
117	#
118	# -bar -xxx -> $opt_bar = '', '-xxx' is next option
119	# -foo -bar -> $opt_foo = '-bar'
120	# -foo -- -> $opt_foo = '--'
121	#
122	# In GNU or POSIX format, option names and values can be combined:
123	#
124	# +foo=blech -> $opt_foo = 'blech'
125	# --bar= -> $opt_bar = ''
126	# --bar=-- -> $opt_bar = '--'
127	#
128	################ Configuration values ################
129	#
130	# $autoabbrev Allow option names to be abbreviated to uniqueness.
131	# Default is 1 unless environment variable
132	# POSIXLY_CORRECT has been set.
133	#
134	# $getopt_compat Allow '+' to start options.
135	# Default is 1 unless environment variable
136	# POSIXLY_CORRECT has been set.
137	#
138	# $option_start Regexp with option starters.
139	# Default is (--\|-) if environment variable
140	# POSIXLY_CORRECT has been set, (--\|-\|\+) otherwise.
141	#
142	# $order Whether non-options are allowed to be mixed with
143	# options.
144	# Default is $REQUIRE_ORDER if environment variable
145	# POSIXLY_CORRECT has been set, $PERMUTE otherwise.
146	#
147	# $ignorecase Ignore case when matching options. Default is 1.
148	#
149	# $debug Enable debugging output. Default is 0.
150
151	################ History ################
152	#
153	# 12-Feb-1994 Johan Vromans
154	# Added "!" for negation.
155	# Released to the net.
156	#
157	# 26-Aug-1992 Johan Vromans
158	# More POSIX/GNU compliance.
159	# Lone dash and double-dash are now independent of the option prefix
160	# that is used.
161	# Make errors in NGetOpt parameters fatal.
162	# Allow options to be mixed with arguments.
163	# Check $ENV{"POSIXLY_CORRECT"} to suppress this.
164	# Allow --foo=bar and +foo=bar (but not -foo=bar).
165	# Allow options to be abbreviated to minimum needed for uniqueness.
166	# (Controlled by configuration variable $autoabbrev.)
167	# Allow alias names for options (e.g. "foo\|bar=s").
168	# Allow "-" in option names (e.g. --pcc-struct-return). Dashes are
169	# translated to "_" to form valid perl identifiers
170	# (e.g. $opt_pcc_struct_return).
171	#
172	# 2-Jun-1992 Johan Vromans
173	# Do not use //o to allow multiple NGetOpt calls with different delimeters.
174	# Prevent typeless option from using previous $array state.
175	# Prevent empty option from being eaten as a (negative) number.
176	#
177	# 25-May-1992 Johan Vromans
178	# Add array options. "foo=s@" will return an array @opt_foo that
179	# contains all values that were supplied. E.g. "-foo one -foo -two" will
180	# return @opt_foo = ("one", "-two");
181	# Correct bug in handling options that allow for a argument when followed
182	# by another option.
183	#
184	# 4-May-1992 Johan Vromans
185	# Add $ignorecase to match options in either case.
186	# Allow '' option.
187	#
188	# 19-Mar-1992 Johan Vromans
189	# Allow require from packages.
190	# NGetOpt is now defined in the package that requires it.
191	# @ARGV and $opt_... are taken from the package that calls it.
192	# Use standard (?) option prefixes: -, -- and +.
193	#
194	# 20-Sep-1990 Johan Vromans
195	# Set options w/o argument to 1.
196	# Correct the dreadful semicolon/require bug.
197
198	################ Configuration Section ################
199
200	{
201
202	# Values for $order. See GNU getopt.c for details.
203	$REQUIRE_ORDER = 0;
204	$PERMUTE = 1;
205	$RETURN_IN_ORDER = 2;
206
207	# Handle POSIX compliancy.
208	if ( defined $ENV{"POSIXLY_CORRECT"} ) {
209	$autoabbrev = 0; # no automatic abbrev of options (???)
210	$getopt_compat = 0; # disallow '+' to start options
211	$option_start = "(--\|-)";
212	$order = $REQUIRE_ORDER;
213	}
214	else {
215	$autoabbrev = 1; # automatic abbrev of options
216	$getopt_compat = 1; # allow '+' to start options
217	$option_start = "(--\|-\|\\+)";
218	$order = $PERMUTE;
219	}
220
221	# Other configurable settings.
222	$debug = 0; # for debugging
223	$ignorecase = 1; # ignore case when matching options
224	$argv_end = "--"; # don't change this!
225	}
226
227	################ Subroutines ################
228
229	sub GetOptions {
230
231	@optionlist = @_; #';
232
233	local ($[) = 0;
234	local ($genprefix) = $option_start;
235	local ($argend) = $argv_end;
236	local ($error) = 0;
237	local ($opt, $optx, $arg, $type, $mand, %opctl);
238	local ($pkg) = (caller)[0];
239	local ($optarg);
240	local (%aliases);
241	local (@ret) = ();
242
243	print STDERR "NGetOpt 1.14 -- called from $pkg\n" if $debug;
244
245	# See if the first element of the optionlist contains option
246	# starter characters.
247	if ( $optionlist[0] =~ /^\W+$/ ) {
248	$genprefix = shift (@optionlist);
249	# Turn into regexp.
250	$genprefix =~ s/(\W)/\\$1/g;
251	$genprefix = "[" . $genprefix . "]";
252	}
253
254	# Verify correctness of optionlist.
255	%opctl = ();
256	foreach $opt ( @optionlist ) {
257	$opt =~ tr/A-Z/a-z/ if $ignorecase;
258	if ( $opt !~ /^(\w+[-\w\|]*)?(!\|[=:][infse]@?)?$/ ) {
259	die ("Error in option spec: \"", $opt, "\"\n");
260	$error++;
261	next;
262	}
263	local ($o, $c, $a) = ($1, $2);
264
265	if ( ! defined $o ) {
266	$opctl{''} = defined $c ? $c : '';
267	}
268	else {
269	# Handle alias names
270	foreach ( split (/\\|/, $o)) {
271	if ( defined $c && $c eq '!' ) {
272	$opctl{"no$_"} = $c;
273	$c = '';
274	}
275	$opctl{$_} = defined $c ? $c : '';
276	if ( defined $a ) {
277	# Note alias.
278	$aliases{$_} = $a;
279	}
280	else {
281	# Set primary name.
282	$a = $_;
283	}
284	}
285	}
286	}
287	@opctl = sort(keys (%opctl)) if $autoabbrev;
288
289	return 0 if $error;
290
291	if ( $debug ) {
292	local ($arrow, $k, $v);
293	$arrow = "=> ";
294	while ( ($k,$v) = each(%opctl) ) {
295	print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
296	$arrow = " ";
297	}
298	}
299
300	# Process argument list
301
302	while ( $#ARGV >= 0 ) {
303
304	# >>> See also the continue block <<<
305
306	#### Get next argument ####
307
308	$opt = shift (@ARGV);
309	print STDERR ("=> option \"", $opt, "\"\n") if $debug;
310	$arg = undef;
311	$optarg = undef;
312	$array = 0;
313
314	#### Determine what we have ####
315
316	# Double dash is option list terminator.
317	if ( $opt eq $argend ) {
318	unshift (@ret, @ARGV) if $order == $PERMUTE;
319	return ($error == 0);
320	}
321	elsif ( $opt =~ /^$genprefix/ ) {
322	# Looks like an option.
323	$opt = $'; # option name (w/o prefix)
324	# If it is a long opt, it may include the value.
325	if (($+ eq "--" \|\| ($getopt_compat && $+ eq "+")) &&
326	$opt =~ /^([^=]+)=/ ) {
327	$opt = $1;
328	$optarg = $';
329	print STDERR ("=> option \"", $opt,
330	"\", optarg = \"$optarg\"\n")
331	if $debug;
332	}
333
334	}
335	# Not an option. Save it if we may permute...
336	elsif ( $order == $PERMUTE ) {
337	push (@ret, $opt);
338	next;
339	}
340	# ...otherwise, terminate.
341	else {
342	# Push back and exit.
343	unshift (@ARGV, $opt);
344	return ($error == 0);
345	}
346
347	#### Look it up ###
348
349	$opt =~ tr/A-Z/a-z/ if $ignorecase;
350
351	local ($tryopt) = $opt;
352	if ( $autoabbrev ) {
353	local ($pat, @hits);
354
355	# Turn option name into pattern.
356	($pat = $opt) =~ s/(\W)/\\$1/g;
357	# Look up in option names.
358	@hits = grep (/^$pat/, @opctl);
359	print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ",
360	"out of ", 0+@opctl, "\n")
361	if $debug;
362
363	# Check for ambiguous results.
364	unless ( (@hits <= 1) \|\| (grep ($_ eq $opt, @hits) == 1) ) {
365	print STDERR ("Option ", $opt, " is ambiguous (",
366	join(", ", @hits), ")\n");
367	$error++;
368	next;
369	}
370
371	# Complete the option name, if appropriate.
372	if ( @hits == 1 && $hits[0] ne $opt ) {
373	$tryopt = $hits[0];
374	print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
375	if $debug;
376	}
377	}
378
379	unless ( defined ( $type = $opctl{$tryopt} ) ) {
380	print STDERR ("Unknown option: ", $opt, "\n");
381	$error++;
382	next;
383	}
384	$opt = $tryopt;
385	print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
386
387	#### Determine argument status ####
388
389	# If it is an option w/o argument, we're almost finished with it.
390	if ( $type eq '' \|\| $type eq '!' ) {
391	if ( defined $optarg ) {
392	print STDERR ("Option ", $opt, " does not take an argument\n");
393	$error++;
394	}
395	elsif ( $type eq '' ) {
396	$arg = 1; # supply explicit value
397	}
398	else {
399	substr ($opt, 0, 2) = ''; # strip NO prefix
400	$arg = 0; # supply explicit value
401	}
402	next;
403	}
404
405	# Get mandatory status and type info.
406	($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
407
408	# Check if there is an option argument available.
409	if ( defined $optarg ? ($optarg eq '') : ($#ARGV < 0) ) {
410
411	# Complain if this option needs an argument.
412	if ( $mand eq "=" ) {
413	print STDERR ("Option ", $opt, " requires an argument\n");
414	$error++;
415	}
416	if ( $mand eq ":" ) {
417	$arg = $type eq "s" ? '' : 0;
418	}
419	next;
420	}
421
422	# Get (possibly optional) argument.
423	$arg = defined $optarg ? $optarg : shift (@ARGV);
424
425	#### Check if the argument is valid for this option ####
426
427	if ( $type eq "s" ) { # string
428	# A mandatory string takes anything.
429	next if $mand eq "=";
430
431	# An optional string takes almost anything.
432	next if defined $optarg;
433	next if $arg eq "-";
434
435	# Check for option or option list terminator.
436	if ($arg eq $argend \|\|
437	$arg =~ /^$genprefix.+/) {
438	# Push back.
439	unshift (@ARGV, $arg);
440	# Supply empty value.
441	$arg = '';
442	}
443	next;
444	}
445
446	if ( $type eq "n" \|\| $type eq "i" ) { # numeric/integer
447	if ( $arg !~ /^-?[0-9]+$/ ) {
448	if ( defined $optarg \|\| $mand eq "=" ) {
449	print STDERR ("Value \"", $arg, "\" invalid for option ",
450	$opt, " (number expected)\n");
451	$error++;
452	undef $arg; # don't assign it
453	}
454	else {
455	# Push back.
456	unshift (@ARGV, $arg);
457	# Supply default value.
458	$arg = 0;
459	}
460	}
461	next;
462	}
463
464	if ( $type eq "f" ) { # fixed real number, int is also ok
465	if ( $arg !~ /^-?[0-9.]+$/ ) {
466	if ( defined $optarg \|\| $mand eq "=" ) {
467	print STDERR ("Value \"", $arg, "\" invalid for option ",
468	$opt, " (real number expected)\n");
469	$error++;
470	undef $arg; # don't assign it
471	}
472	else {
473	# Push back.
474	unshift (@ARGV, $arg);
475	# Supply default value.
476	$arg = 0.0;
477	}
478	}
479	next;
480	}
481
482	die ("NGetOpt internal error (Can't happen)\n");
483	}
484
485	continue {
486	if ( defined $arg ) {
487	$opt = $aliases{$opt} if defined $aliases{$opt};
488	# Make sure a valid perl identifier results.
489	$opt =~ s/\W/_/g;
490	if ( $array ) {
491	print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
492	if $debug;
493	eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
494	}
495	else {
496	print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
497	if $debug;
498	eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
499	}
500	}
501	}
502
503	if ( $order == $PERMUTE && @ret > 0 ) {
504	unshift (@ARGV, @ret);
505	}
506	return ($error == 0);
507	}
508
509	################ Package return ################
510
511	1;
512
513