Attachment 7925 Details for Bug 35523 – модифицированный /usr/share/perl5/Getopt/Long.pm (изначально из perl-base-5.26.2-alt3)

модифицированный /usr/share/perl5/Getopt/Long.pm (изначально из perl-base-5.26.2-alt3)

Long.pm (text/plain), 80.91 KB, created by Michael Shigorin on 2018-12-28 21:21:35 MSK

(hide)

Description:

Filename:

MIME Type:

Creator: Michael Shigorin

Created: 2018-12-28 21:21:35 MSK

Size: 80.91 KB

patch

obsolete

>#! perl
>
># Getopt::Long.pm -- Universal options parsing
># Author          : Johan Vromans
># Created On      : Tue Sep 11 15:00:12 1990
># Last Modified By: Johan Vromans
># Last Modified On: Thu Jun  9 14:50:37 2016
># Update Count    : 1699
># Status          : Released
>
>################ Module Preamble ################
>
>package Getopt::Long;
>
>use 5.004;
>
>use strict;
>
>use vars qw($VERSION);
>$VERSION        =  2.49;
># For testing versions only.
>use vars qw($VERSION_STRING);
>$VERSION_STRING = "2.49";
>
>use Exporter;
>use vars qw(@ISA @EXPORT @EXPORT_OK);
>@ISA = qw(Exporter);
>
># Exported subroutines.
>sub GetOptions(@);		# always
>sub GetOptionsFromArray(@);	# on demand
>sub GetOptionsFromString(@);	# on demand
>sub Configure(@);		# on demand
>sub HelpMessage(@);		# on demand
>sub VersionMessage(@);		# in demand
>
>BEGIN {
>    # Init immediately so their contents can be used in the 'use vars' below.
>    @EXPORT    = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
>    @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure
>		    &GetOptionsFromArray &GetOptionsFromString);
>}
>
># User visible variables.
>use vars @EXPORT, @EXPORT_OK;
>use vars qw($error $debug $major_version $minor_version);
># Deprecated visible variables.
>use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
>	    $passthrough);
># Official invisible variables.
>use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);
>
># Really invisible variables.
>my $bundling_values;
>
># Public subroutines.
>sub config(@);			# deprecated name
>
># Private subroutines.
>sub ConfigDefaults();
>sub ParseOptionSpec($$);
>sub OptCtl($);
>sub FindOption($$$$$);
>sub ValidValue ($$$$$);
>
>################ Local Variables ################
>
># $requested_version holds the version that was mentioned in the 'use'
># or 'require', if any. It can be used to enable or disable specific
># features.
>my $requested_version = 0;
>
>################ Resident subroutines ################
>
>sub ConfigDefaults() {
>    # Handle POSIX compliancy.
>    if ( defined $ENV{"POSIXLY_CORRECT"} ) {
>	$genprefix = "(--|-)";
>	$autoabbrev = 0;		# no automatic abbrev of options
>	$bundling = 0;			# no bundling of single letter switches
>	$getopt_compat = 0;		# disallow '+' to start options
>	$order = $REQUIRE_ORDER;
>    }
>    else {
>	$genprefix = "(--|-|\\+)";
>	$autoabbrev = 1;		# automatic abbrev of options
>	$bundling = 0;			# bundling off by default
>	$getopt_compat = 1;		# allow '+' to start options
>	$order = $PERMUTE;
>    }
>    # Other configurable settings.
>    $debug = 0;			# for debugging
>    $error = 0;			# error tally
>    $ignorecase = 1;		# ignore case when matching options
>    $passthrough = 0;		# leave unrecognized options alone
>    $gnu_compat = 0;		# require --opt=val if value is optional
>    $longprefix = "(--)";       # what does a long prefix look like
>    $bundling_values = 0;	# no bundling of values
>}
>
># Override import.
>sub import {
>    my $pkg = shift;		# package
>    my @syms = ();		# symbols to import
>    my @config = ();		# configuration
>    my $dest = \@syms;		# symbols first
>    for ( @_ ) {
>	if ( $_ eq ':config' ) {
>	    $dest = \@config;	# config next
>	    next;
>	}
>	push(@$dest, $_);	# push
>    }
>    # Hide one level and call super.
>    local $Exporter::ExportLevel = 1;
>    push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions
>    $requested_version = 0;
>    $pkg->SUPER::import(@syms);
>    # And configure.
>    Configure(@config) if @config;
>}
>
>################ Initialization ################
>
># Values for $order. See GNU getopt.c for details.
>($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
># Version major/minor numbers.
>($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
>
>ConfigDefaults();
>
>################ OO Interface ################
>
>package Getopt::Long::Parser;
>
># Store a copy of the default configuration. Since ConfigDefaults has
># just been called, what we get from Configure is the default.
>my $default_config = do {
>    Getopt::Long::Configure ()
>};
>
>sub new {
>    my $that = shift;
>    my $class = ref($that) || $that;
>    my %atts = @_;
>
>    # Register the callers package.
>    my $self = { caller_pkg => (caller)[0] };
>
>    bless ($self, $class);
>
>    # Process config attributes.
>    if ( defined $atts{config} ) {
>	my $save = Getopt::Long::Configure ($default_config, @{$atts{config}});
>	$self->{settings} = Getopt::Long::Configure ($save);
>	delete ($atts{config});
>    }
>    # Else use default config.
>    else {
>	$self->{settings} = $default_config;
>    }
>
>    if ( %atts ) {		# Oops
>	die(__PACKAGE__.": unhandled attributes: ".
>	    join(" ", sort(keys(%atts)))."\n");
>    }
>
>    $self;
>}
>
>sub configure {
>    my ($self) = shift;
>
>    # Restore settings, merge new settings in.
>    my $save = Getopt::Long::Configure ($self->{settings}, @_);
>
>    # Restore orig config and save the new config.
>    $self->{settings} = Getopt::Long::Configure ($save);
>}
>
>sub getoptions {
>    my ($self) = shift;
>
>    return $self->getoptionsfromarray(\@ARGV, @_);
>}
>
>sub getoptionsfromarray {
>    my ($self) = shift;
>
>    # Restore config settings.
>    my $save = Getopt::Long::Configure ($self->{settings});
>
>    # Call main routine.
>    my $ret = 0;
>    $Getopt::Long::caller = $self->{caller_pkg};
>
>    eval {
>	# Locally set exception handler to default, otherwise it will
>	# be called implicitly here, and again explicitly when we try
>	# to deliver the messages.
>	local ($SIG{__DIE__}) = 'DEFAULT';
>	$ret = Getopt::Long::GetOptionsFromArray (@_);
>    };
>
>    # Restore saved settings.
>    Getopt::Long::Configure ($save);
>
>    # Handle errors and return value.
>    die ($@) if $@;
>    return $ret;
>}
>
>package Getopt::Long;
>
>################ Back to Normal ################
>
># Indices in option control info.
># Note that ParseOptions uses the fields directly. Search for 'hard-wired'.
>use constant CTL_TYPE    => 0;
>#use constant   CTL_TYPE_FLAG   => '';
>#use constant   CTL_TYPE_NEG    => '!';
>#use constant   CTL_TYPE_INCR   => '+';
>#use constant   CTL_TYPE_INT    => 'i';
>#use constant   CTL_TYPE_INTINC => 'I';
>#use constant   CTL_TYPE_XINT   => 'o';
>#use constant   CTL_TYPE_FLOAT  => 'f';
>#use constant   CTL_TYPE_STRING => 's';
>
>use constant CTL_CNAME   => 1;
>
>use constant CTL_DEFAULT => 2;
>
>use constant CTL_DEST    => 3;
> use constant   CTL_DEST_SCALAR => 0;
> use constant   CTL_DEST_ARRAY  => 1;
> use constant   CTL_DEST_HASH   => 2;
> use constant   CTL_DEST_CODE   => 3;
>
>use constant CTL_AMIN    => 4;
>use constant CTL_AMAX    => 5;
>
># FFU.
>#use constant CTL_RANGE   => ;
>#use constant CTL_REPEAT  => ;
>
># Rather liberal patterns to match numbers.
>use constant PAT_INT   => "[-+]?_*[0-9][0-9_]*";
>use constant PAT_XINT  =>
>  "(?:".
>	  "[-+]?_*[1-9][0-9_]*".
>  "|".
>	  "0x_*[0-9a-f][0-9a-f_]*".
>  "|".
>	  "0b_*[01][01_]*".
>  "|".
>	  "0[0-7_]*".
>  ")";
>use constant PAT_FLOAT =>
>  "[-+]?".			# optional sign
>  "(?=[0-9.])".			# must start with digit or dec.point
>  "[0-9_]*".			# digits before the dec.point
>  "(\.[0-9_]+)?".		# optional fraction
>  "([eE][-+]?[0-9_]+)?";	# optional exponent
>
>sub GetOptions(@) {
>    # Shift in default array.
>    unshift(@_, \@ARGV);
>    # Try to keep caller() and Carp consistent.
>    goto &GetOptionsFromArray;
>}
>
>sub GetOptionsFromString(@) {
>    my ($string) = shift;
>    require Text::ParseWords;
>    my $args = [ Text::ParseWords::shellwords($string) ];
>    $caller ||= (caller)[0];	# current context
>    my $ret = GetOptionsFromArray($args, @_);
>    return ( $ret, $args ) if wantarray;
>    if ( @$args ) {
>	$ret = 0;
>	warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
>    }
>    $ret;
>}
>
>sub GetOptionsFromArray(@) {
>
>    my ($argv, @optionlist) = @_;	# local copy of the option descriptions
>    my $argend = '--';		# option list terminator
>    my %opctl = ();		# table of option specs
>    my $pkg = $caller || (caller)[0];	# current context
>				# Needed if linkage is omitted.
>    my @ret = ();		# accum for non-options
>    my %linkage;		# linkage
>    my $userlinkage;		# user supplied HASH
>    my $opt;			# current option
>    my $prefix = $genprefix;	# current prefix
>
>    $error = '';
>
>    if ( $debug ) {
>	# Avoid some warnings if debugging.
>	local ($^W) = 0;
>	print STDERR
>	  ("Getopt::Long $Getopt::Long::VERSION ",
>	   "called from package \"$pkg\".",
>	   "\n  ",
>	   "argv: ",
>	   defined($argv)
>	   ? UNIVERSAL::isa( $argv, 'ARRAY' ) ? "(@$argv)" : $argv
>	   : "<undef>",
>	   "\n  ",
>	   "autoabbrev=$autoabbrev,".
>	   "bundling=$bundling,",
>	   "bundling_values=$bundling_values,",
>	   "getopt_compat=$getopt_compat,",
>	   "gnu_compat=$gnu_compat,",
>	   "order=$order,",
>	   "\n  ",
>	   "ignorecase=$ignorecase,",
>	   "requested_version=$requested_version,",
>	   "passthrough=$passthrough,",
>	   "genprefix=\"$genprefix\",",
>	   "longprefix=\"$longprefix\".",
>	   "\n");
>    }
>
>    # Check for ref HASH as first argument.
>    # First argument may be an object. It's OK to use this as long
>    # as it is really a hash underneath.
>    $userlinkage = undef;
>    if ( @optionlist && ref($optionlist[0]) and
>	 UNIVERSAL::isa($optionlist[0],'HASH') ) {
>	$userlinkage = shift (@optionlist);
>	print STDERR ("=> user linkage: $userlinkage\n") if $debug;
>    }
>
>    # See if the first element of the optionlist contains option
>    # starter characters.
>    # Be careful not to interpret '<>' as option starters.
>    if ( @optionlist && $optionlist[0] =~ /^\W+$/
>	 && !($optionlist[0] eq '<>'
>	      && @optionlist > 0
>	      && ref($optionlist[1])) ) {
>	$prefix = shift (@optionlist);
>	# Turn into regexp. Needs to be parenthesized!
>	$prefix =~ s/(\W)/\\$1/g;
>	$prefix = "([" . $prefix . "])";
>	print STDERR ("=> prefix=\"$prefix\"\n") if $debug;
>    }
>
>    # Verify correctness of optionlist.
>    %opctl = ();
>    while ( @optionlist ) {
>	my $opt = shift (@optionlist);
>
>	unless ( defined($opt) ) {
>	    $error .= "Undefined argument in option spec\n";
>	    next;
>	}
>
>	# Strip leading prefix so people can specify "--foo=i" if they like.
>	$opt = $+ if $opt =~ /^$prefix+(.*)$/s;
>
>	if ( $opt eq '<>' ) {
>	    if ( (defined $userlinkage)
>		&& !(@optionlist > 0 && ref($optionlist[0]))
>		&& (exists $userlinkage->{$opt})
>		&& ref($userlinkage->{$opt}) ) {
>		unshift (@optionlist, $userlinkage->{$opt});
>	    }
>	    unless ( @optionlist > 0
>		    && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
>		$error .= "Option spec <> requires a reference to a subroutine\n";
>		# Kill the linkage (to avoid another error).
>		shift (@optionlist)
>		  if @optionlist && ref($optionlist[0]);
>		next;
>	    }
>	    $linkage{'<>'} = shift (@optionlist);
>	    next;
>	}
>
>	# Parse option spec.
>	my ($name, $orig) = ParseOptionSpec ($opt, \%opctl);
>	unless ( defined $name ) {
>	    # Failed. $orig contains the error message. Sorry for the abuse.
>	    $error .= $orig;
>	    # Kill the linkage (to avoid another error).
>	    shift (@optionlist)
>	      if @optionlist && ref($optionlist[0]);
>	    next;
>	}
>
>	# If no linkage is supplied in the @optionlist, copy it from
>	# the userlinkage if available.
>	if ( defined $userlinkage ) {
>	    unless ( @optionlist > 0 && ref($optionlist[0]) ) {
>		if ( exists $userlinkage->{$orig} &&
>		     ref($userlinkage->{$orig}) ) {
>		    print STDERR ("=> found userlinkage for \"$orig\": ",
>				  "$userlinkage->{$orig}\n")
>			if $debug;
>		    unshift (@optionlist, $userlinkage->{$orig});
>		}
>		else {
>		    # Do nothing. Being undefined will be handled later.
>		    next;
>		}
>	    }
>	}
>
>	# Copy the linkage. If omitted, link to global variable.
>	if ( @optionlist > 0 && ref($optionlist[0]) ) {
>	    print STDERR ("=> link \"$orig\" to $optionlist[0]\n")
>		if $debug;
>	    my $rl = ref($linkage{$orig} = shift (@optionlist));
>
>	    if ( $rl eq "ARRAY" ) {
>		$opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY;
>	    }
>	    elsif ( $rl eq "HASH" ) {
>		$opctl{$name}[CTL_DEST] = CTL_DEST_HASH;
>	    }
>	    elsif ( $rl eq "SCALAR" || $rl eq "REF" ) {
>#		if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
>#		    my $t = $linkage{$orig};
>#		    $$t = $linkage{$orig} = [];
>#		}
>#		elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
>#		}
>#		else {
>		    # Ok.
>#		}
>	    }
>	    elsif ( $rl eq "CODE" ) {
>		# Ok.
>	    }
>	    else {
>		$error .= "Invalid option linkage for \"$opt\"\n";
>	    }
>	}
>	else {
>	    # Link to global $opt_XXX variable.
>	    # Make sure a valid perl identifier results.
>	    my $ov = $orig;
>	    $ov =~ s/\W/_/g;
>	    if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
>		print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n")
>		    if $debug;
>		eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;");
>	    }
>	    elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
>		print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n")
>		    if $debug;
>		eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;");
>	    }
>	    else {
>		print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n")
>		    if $debug;
>		eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;");
>	    }
>	}
>
>	if ( $opctl{$name}[CTL_TYPE] eq 'I'
>	     && ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY
>		  || $opctl{$name}[CTL_DEST] == CTL_DEST_HASH )
>	   ) {
>	    $error .= "Invalid option linkage for \"$opt\"\n";
>	}
>
>    }
>
>    $error .= "GetOptionsFromArray: 1st parameter is not an array reference\n"
>      unless $argv && UNIVERSAL::isa( $argv, 'ARRAY' );
>
>    # Bail out if errors found.
>    die ($error) if $error;
>    $error = 0;
>
>    # Supply --version and --help support, if needed and allowed.
>    if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) {
>	if ( !defined($opctl{version}) ) {
>	    $opctl{version} = ['','version',0,CTL_DEST_CODE,undef];
>	    $linkage{version} = \&VersionMessage;
>	}
>	$auto_version = 1;
>    }
>    if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) {
>	if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) {
>	    $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef];
>	    $linkage{help} = \&HelpMessage;
>	}
>	$auto_help = 1;
>    }
>
>    # Show the options tables if debugging.
>    if ( $debug ) {
>	my ($arrow, $k, $v);
>	$arrow = "=> ";
>	while ( ($k,$v) = each(%opctl) ) {
>	    print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n");
>	    $arrow = "   ";
>	}
>    }
>
>    # Process argument list
>    my $goon = 1;
>    while ( $goon && @$argv > 0 ) {
>
>	# Get next argument.
>	$opt = shift (@$argv);
>	print STDERR ("=> arg \"", $opt, "\"\n") if $debug;
>
>	# Double dash is option list terminator.
>	if ( defined($opt) && $opt eq $argend ) {
>	  push (@ret, $argend) if $passthrough;
>	  last;
>	}
>
>	# Look it up.
>	my $tryopt = $opt;
>	my $found;		# success status
>	my $key;		# key (if hash type)
>	my $arg;		# option argument
>	my $ctl;		# the opctl entry
>
>	($found, $opt, $ctl, $arg, $key) =
>	  FindOption ($argv, $prefix, $argend, $opt, \%opctl);
>
>	if ( $found ) {
>
>	    # FindOption undefines $opt in case of errors.
>	    next unless defined $opt;
>
>	    my $argcnt = 0;
>	    while ( defined $arg ) {
>
>		# Get the canonical name.
>		print STDERR ("=> cname for \"$opt\" is ") if $debug;
>		$opt = $ctl->[CTL_CNAME];
>		print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug;
>
>		if ( defined $linkage{$opt} ) {
>		    print STDERR ("=> ref(\$L{$opt}) -> ",
>				  ref($linkage{$opt}), "\n") if $debug;
>
>		    if ( ref($linkage{$opt}) eq 'SCALAR'
>			 || ref($linkage{$opt}) eq 'REF' ) {
>			if ( $ctl->[CTL_TYPE] eq '+' ) {
>			    print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
>			      if $debug;
>			    if ( defined ${$linkage{$opt}} ) {
>			        ${$linkage{$opt}} += $arg;
>			    }
>		            else {
>			        ${$linkage{$opt}} = $arg;
>			    }
>			}
>			elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
>			    print STDERR ("=> ref(\$L{$opt}) auto-vivified",
>					  " to ARRAY\n")
>			      if $debug;
>			    my $t = $linkage{$opt};
>			    $$t = $linkage{$opt} = [];
>			    print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
>			      if $debug;
>			    push (@{$linkage{$opt}}, $arg);
>			}
>			elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
>			    print STDERR ("=> ref(\$L{$opt}) auto-vivified",
>					  " to HASH\n")
>			      if $debug;
>			    my $t = $linkage{$opt};
>			    $$t = $linkage{$opt} = {};
>			    print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
>			      if $debug;
>			    $linkage{$opt}->{$key} = $arg;
>			}
>			else {
>			    print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
>			      if $debug;
>			    ${$linkage{$opt}} = $arg;
>		        }
>		    }
>		    elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
>			print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
>			    if $debug;
>			push (@{$linkage{$opt}}, $arg);
>		    }
>		    elsif ( ref($linkage{$opt}) eq 'HASH' ) {
>			print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
>			    if $debug;
>			$linkage{$opt}->{$key} = $arg;
>		    }
>		    elsif ( ref($linkage{$opt}) eq 'CODE' ) {
>			print STDERR ("=> &L{$opt}(\"$opt\"",
>				      $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
>				      ", \"$arg\")\n")
>			    if $debug;
>			my $eval_error = do {
>			    local $@;
>			    local $SIG{__DIE__}  = 'DEFAULT';
>			    eval {
>				&{$linkage{$opt}}
>				  (Getopt::Long::CallBack->new
>				   (name    => $opt,
>				    ctl     => $ctl,
>				    opctl   => \%opctl,
>				    linkage => \%linkage,
>				    prefix  => $prefix,
>				   ),
>				   $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
>				   $arg);
>			    };
>			    $@;
>			};
>			print STDERR ("=> die($eval_error)\n")
>			  if $debug && $eval_error ne '';
>			if ( $eval_error =~ /^!/ ) {
>			    if ( $eval_error =~ /^!FINISH\b/ ) {
>				$goon = 0;
>			    }
>			}
>			elsif ( $eval_error ne '' ) {
>			    warn ($eval_error);
>			    $error++;
>			}
>		    }
>		    else {
>			print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
>				      "\" in linkage\n");
>			die("Getopt::Long -- internal error!\n");
>		    }
>		}
>		# No entry in linkage means entry in userlinkage.
>		elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
>		    if ( defined $userlinkage->{$opt} ) {
>			print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
>			    if $debug;
>			push (@{$userlinkage->{$opt}}, $arg);
>		    }
>		    else {
>			print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
>			    if $debug;
>			$userlinkage->{$opt} = [$arg];
>		    }
>		}
>		elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
>		    if ( defined $userlinkage->{$opt} ) {
>			print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
>			    if $debug;
>			$userlinkage->{$opt}->{$key} = $arg;
>		    }
>		    else {
>			print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
>			    if $debug;
>			$userlinkage->{$opt} = {$key => $arg};
>		    }
>		}
>		else {
>		    if ( $ctl->[CTL_TYPE] eq '+' ) {
>			print STDERR ("=> \$L{$opt} += \"$arg\"\n")
>			  if $debug;
>			if ( defined $userlinkage->{$opt} ) {
>			    $userlinkage->{$opt} += $arg;
>			}
>			else {
>			    $userlinkage->{$opt} = $arg;
>			}
>		    }
>		    else {
>			print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
>			$userlinkage->{$opt} = $arg;
>		    }
>		}
>
>		$argcnt++;
>		last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
>		undef($arg);
>
>		# Need more args?
>		if ( $argcnt < $ctl->[CTL_AMIN] ) {
>		    if ( @$argv ) {
>			if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) {
>			    $arg = shift(@$argv);
>			    if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) {
>				$arg =~ tr/_//d;
>				$arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/
>				  ? oct($arg)
>				  : 0+$arg
>			    }
>			    ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
>			      if $ctl->[CTL_DEST] == CTL_DEST_HASH;
>			    next;
>			}
>			warn("Value \"$$argv[0]\" invalid for option $opt\n");
>			$error++;
>		    }
>		    else {
>			warn("Insufficient arguments for option $opt\n");
>			$error++;
>		    }
>		}
>
>		# Any more args?
>		if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) {
>		    $arg = shift(@$argv);
>		    if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) {
>			$arg =~ tr/_//d;
>			$arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/
>			  ? oct($arg)
>			  : 0+$arg
>		    }
>		    ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
>		      if $ctl->[CTL_DEST] == CTL_DEST_HASH;
>		    next;
>		}
>	    }
>	}
>
>	# Not an option. Save it if we $PERMUTE and don't have a <>.
>	elsif ( $order == $PERMUTE ) {
>	    # Try non-options call-back.
>	    my $cb;
>	    if ( defined ($cb = $linkage{'<>'}) ) {
>		print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
>		  if $debug;
>		my $eval_error = do {
>		    local $@;
>		    local $SIG{__DIE__}  = 'DEFAULT';
>		    eval {
>			# The arg to <> cannot be the CallBack object
>			# since it may be passed to other modules that
>			# get confused (e.g., Archive::Tar). Well,
>			# it's not relevant for this callback anyway.
>			&$cb($tryopt);
>		    };
>		    $@;
>		};
>		print STDERR ("=> die($eval_error)\n")
>		  if $debug && $eval_error ne '';
>		if ( $eval_error =~ /^!/ ) {
>		    if ( $eval_error =~ /^!FINISH\b/ ) {
>			$goon = 0;
>		    }
>		}
>		elsif ( $eval_error ne '' ) {
>		    warn ($eval_error);
>		    $error++;
>		}
>	    }
>	    else {
>		print STDERR ("=> saving \"$tryopt\" ",
>			      "(not an option, may permute)\n") if $debug;
>		push (@ret, $tryopt);
>	    }
>	    next;
>	}
>
>	# ...otherwise, terminate.
>	else {
>	    # Push this one back and exit.
>	    unshift (@$argv, $tryopt);
>	    return ($error == 0);
>	}
>
>    }
>
>    # Finish.
>    if ( @ret && $order == $PERMUTE ) {
>	#  Push back accumulated arguments
>	print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
>	    if $debug;
>	unshift (@$argv, @ret);
>    }
>
>    return ($error == 0);
>}
>
># A readable representation of what's in an optbl.
>sub OptCtl ($) {
>    my ($v) = @_;
>    my @v = map { defined($_) ? ($_) : ("<undef>") } @$v;
>    "[".
>      join(",",
>	   "\"$v[CTL_TYPE]\"",
>	   "\"$v[CTL_CNAME]\"",
>	   "\"$v[CTL_DEFAULT]\"",
>	   ("\$","\@","\%","\&")[$v[CTL_DEST] || 0],
>	   $v[CTL_AMIN] || '',
>	   $v[CTL_AMAX] || '',
>#	   $v[CTL_RANGE] || '',
>#	   $v[CTL_REPEAT] || '',
>	  ). "]";
>}
>
># Parse an option specification and fill the tables.
>sub ParseOptionSpec ($$) {
>    my ($opt, $opctl) = @_;
>
>    # Match option spec.
>    if ( $opt !~ m;^
>		   (
>		     # Option name
>		     (?: \w+[-\w]* )
>		     # Alias names, or "?"
>		     (?: \| (?: \? | \w[-\w]* ) )*
>		     # Aliases
>		     (?: \| (?: [^-|!+=:][^|!+=:]* )? )*
>		   )?
>		   (
>		     # Either modifiers ...
>		     [!+]
>		     |
>		     # ... or a value/dest/repeat specification
>		     [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
>		     |
>		     # ... or an optional-with-default spec
>		     : (?: -?\d+ | \+ ) [@%]?
>		   )?
>		   $;x ) {
>	return (undef, "Error in option spec: \"$opt\"\n");
>    }
>
>    my ($names, $spec) = ($1, $2);
>    $spec = '' unless defined $spec;
>
>    # $orig keeps track of the primary name the user specified.
>    # This name will be used for the internal or external linkage.
>    # In other words, if the user specifies "FoO|BaR", it will
>    # match any case combinations of 'foo' and 'bar', but if a global
>    # variable needs to be set, it will be $opt_FoO in the exact case
>    # as specified.
>    my $orig;
>
>    my @names;
>    if ( defined $names ) {
>	@names =  split (/\|/, $names);
>	$orig = $names[0];
>    }
>    else {
>	@names = ('');
>	$orig = '';
>    }
>
>    # Construct the opctl entries.
>    my $entry;
>    if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
>	# Fields are hard-wired here.
>	$entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0];
>    }
>    elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) {
>	my $def = $1;
>	my $dest = $2;
>	my $type = $def eq '+' ? 'I' : 'i';
>	$dest ||= '$';
>	$dest = $dest eq '@' ? CTL_DEST_ARRAY
>	  : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
>	# Fields are hard-wired here.
>	$entry = [$type,$orig,$def eq '+' ? undef : $def,
>		  $dest,0,1];
>    }
>    else {
>	my ($mand, $type, $dest) =
>	  $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
>	return (undef, "Cannot repeat while bundling: \"$opt\"\n")
>	  if $bundling && defined($4);
>	my ($mi, $cm, $ma) = ($5, $6, $7);
>	return (undef, "{0} is useless in option spec: \"$opt\"\n")
>	  if defined($mi) && !$mi && !defined($ma) && !defined($cm);
>
>	$type = 'i' if $type eq 'n';
>	$dest ||= '$';
>	$dest = $dest eq '@' ? CTL_DEST_ARRAY
>	  : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
>	# Default minargs to 1/0 depending on mand status.
>	$mi = $mand eq '=' ? 1 : 0 unless defined $mi;
>	# Adjust mand status according to minargs.
>	$mand = $mi ? '=' : ':';
>	# Adjust maxargs.
>	$ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
>	return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
>	  if defined($ma) && !$ma;
>	return (undef, "Max less than min in option spec: \"$opt\"\n")
>	  if defined($ma) && $ma < $mi;
>
>	# Fields are hard-wired here.
>	$entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
>    }
>
>    # Process all names. First is canonical, the rest are aliases.
>    my $dups = '';
>    foreach ( @names ) {
>
>	$_ = lc ($_)
>	  if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
>
>	if ( exists $opctl->{$_} ) {
>	    $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
>	}
>
>	if ( $spec eq '!' ) {
>	    $opctl->{"no$_"} = $entry;
>	    $opctl->{"no-$_"} = $entry;
>	    $opctl->{$_} = [@$entry];
>	    $opctl->{$_}->[CTL_TYPE] = '';
>	}
>	else {
>	    $opctl->{$_} = $entry;
>	}
>    }
>
>    if ( $dups && $^W ) {
>	foreach ( split(/\n+/, $dups) ) {
>	    warn($_."\n");
>	}
>    }
>    ($names[0], $orig);
>}
>
># Option lookup.
>sub FindOption ($$$$$) {
>
>	warn "FO:[@_]";
>
>    # returns (1, $opt, $ctl, $arg, $key) if okay,
>    # returns (1, undef) if option in error,
>    # returns (0) otherwise.
>
>    my ($argv, $prefix, $argend, $opt, $opctl) = @_;
>
>    print STDERR ("=> find \"$opt\"\n") if $debug;
>
>    #warn $opt =~ /^($prefix)(.*)$/s;
>    #warn "ZZ".[0,1]->[$opt =~ /^($prefix)(.*)$/s]; 
>    {use re 'debug';warn "ZZ".[0,1]->[$opt =~ /^($prefix)(.*)$/s];}
>
>    return (0) unless defined($opt);
>    return (0) unless $opt =~ /^($prefix)(.*)$/s;
>    return (0) if $opt eq "-" && !defined $opctl->{''};
>
>    $opt = substr( $opt, length($1) ); # retain taintedness
>    my $starter = $1;
>
>    print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
>
>    my $optarg;			# value supplied with --opt=value
>    my $rest;			# remainder from unbundling
>
>    # If it is a long option, it may include the value.
>    # With getopt_compat, only if not bundling.
>    if ( ($starter=~/^$longprefix$/
>	  || ($getopt_compat && ($bundling == 0 || $bundling == 2)))
>	 && (my $oppos = index($opt, '=', 1)) > 0) {
>	my $optorg = $opt;
>	$opt = substr($optorg, 0, $oppos);
>	$optarg = substr($optorg, $oppos + 1); # retain tainedness
>	print STDERR ("=> option \"", $opt,
>		      "\", optarg = \"$optarg\"\n") if $debug;
>    }
>
>    #### Look it up ###
>
>    my $tryopt = $opt;		# option to try
>
>    if ( ( $bundling || $bundling_values ) && $starter eq '-' ) {
>
>	# To try overrides, obey case ignore.
>	$tryopt = $ignorecase ? lc($opt) : $opt;
>
>	# If bundling == 2, long options can override bundles.
>	if ( $bundling == 2 && length($tryopt) > 1
>	     && defined ($opctl->{$tryopt}) ) {
>	    print STDERR ("=> $starter$tryopt overrides unbundling\n")
>	      if $debug;
>	}
>
>	# If bundling_values, option may be followed by the value.
>	elsif ( $bundling_values ) {
>	    $tryopt = $opt;
>	    # Unbundle single letter option.
>	    $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
>	    $tryopt = substr ($tryopt, 0, 1);
>	    $tryopt = lc ($tryopt) if $ignorecase > 1;
>	    print STDERR ("=> $starter$tryopt unbundled from ",
>			  "$starter$tryopt$rest\n") if $debug;
>	    # Whatever remains may not be considered an option.
>	    $optarg = $rest eq '' ? undef : $rest;
>	    $rest = undef;
>	}
>
>	# Split off a single letter and leave the rest for
>	# further processing.
>	else {
>	    $tryopt = $opt;
>	    # Unbundle single letter option.
>	    $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
>	    $tryopt = substr ($tryopt, 0, 1);
>	    $tryopt = lc ($tryopt) if $ignorecase > 1;
>	    print STDERR ("=> $starter$tryopt unbundled from ",
>			  "$starter$tryopt$rest\n") if $debug;
>	    $rest = undef unless $rest ne '';
>	}
>    }
>
>    # Try auto-abbreviation.
>    elsif ( $autoabbrev && $opt ne "" ) {
>	# Sort the possible long option names.
>	my @names = sort(keys (%$opctl));
>	# Downcase if allowed.
>	$opt = lc ($opt) if $ignorecase;
>	$tryopt = $opt;
>	# Turn option name into pattern.
>	my $pat = quotemeta ($opt);
>	# Look up in option names.
>	my @hits = grep (/^$pat/, @names);
>	print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
>		      "out of ", scalar(@names), "\n") if $debug;
>
>	# Check for ambiguous results.
>	unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
>	    # See if all matches are for the same option.
>	    my %hit;
>	    foreach ( @hits ) {
>		my $hit = $opctl->{$_}->[CTL_CNAME]
>		  if defined $opctl->{$_}->[CTL_CNAME];
>		$hit = "no" . $hit if $opctl->{$_}->[CTL_TYPE] eq '!';
>		$hit{$hit} = 1;
>	    }
>	    # Remove auto-supplied options (version, help).
>	    if ( keys(%hit) == 2 ) {
>		if ( $auto_version && exists($hit{version}) ) {
>		    delete $hit{version};
>		}
>		elsif ( $auto_help && exists($hit{help}) ) {
>		    delete $hit{help};
>		}
>	    }
>	    # Now see if it really is ambiguous.
>	    unless ( keys(%hit) == 1 ) {
>		return (0) if $passthrough;
>		warn ("Option ", $opt, " is ambiguous (",
>		      join(", ", @hits), ")\n");
>		$error++;
>		return (1, undef);
>	    }
>	    @hits = keys(%hit);
>	}
>
>	# Complete the option name, if appropriate.
>	if ( @hits == 1 && $hits[0] ne $opt ) {
>	    $tryopt = $hits[0];
>	    $tryopt = lc ($tryopt) if $ignorecase;
>	    print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
>		if $debug;
>	}
>    }
>
>    # Map to all lowercase if ignoring case.
>    elsif ( $ignorecase ) {
>	$tryopt = lc ($opt);
>    }
>
>    # Check validity by fetching the info.
>    my $ctl = $opctl->{$tryopt};
>    unless  ( defined $ctl ) {
>	return (0) if $passthrough;
>	# Pretend one char when bundling.
>	if ( $bundling == 1 && length($starter) == 1 ) {
>	    $opt = substr($opt,0,1);
>            unshift (@$argv, $starter.$rest) if defined $rest;
>	}
>	if ( $opt eq "" ) {
>	    warn ("Missing option after ", $starter, "\n");
>	}
>	else {
>	    warn ("Unknown option: ", $opt, "\n");
>	}
>	$error++;
>	return (1, undef);
>    }
>    # Apparently valid.
>    $opt = $tryopt;
>    print STDERR ("=> found ", OptCtl($ctl),
>		  " for \"", $opt, "\"\n") if $debug;
>
>    #### Determine argument status ####
>
>    # If it is an option w/o argument, we're almost finished with it.
>    my $type = $ctl->[CTL_TYPE];
>    my $arg;
>
>    if ( $type eq '' || $type eq '!' || $type eq '+' ) {
>	if ( defined $optarg ) {
>	    return (0) if $passthrough;
>	    warn ("Option ", $opt, " does not take an argument\n");
>	    $error++;
>	    undef $opt;
>	    undef $optarg if $bundling_values;
>	}
>	elsif ( $type eq '' || $type eq '+' ) {
>	    # Supply explicit value.
>	    $arg = 1;
>	}
>	else {
>	    $opt =~ s/^no-?//i;	# strip NO prefix
>	    $arg = 0;		# supply explicit value
>	}
>	unshift (@$argv, $starter.$rest) if defined $rest;
>	return (1, $opt, $ctl, $arg);
>    }
>
>    # Get mandatory status and type info.
>    my $mand = $ctl->[CTL_AMIN];
>
>    # Check if there is an option argument available.
>    if ( $gnu_compat ) {
>	my $optargtype = 0; # 0 = none, 1 = empty, 2 = nonempty
>	$optargtype = ( !defined($optarg) ? 0 : ( (length($optarg) == 0) ? 1 : 2 ) );
>    return (1, $opt, $ctl, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : undef)
>	  if (($optargtype == 0) && !$mand);
>	return (1, $opt, $ctl, $type eq 's' ? '' : 0)
>	  if $optargtype == 1;  # --foo=  -> return nothing
>    }
>
>    # Check if there is an option argument available.
>    if ( defined $optarg
>	 ? ($optarg eq '')
>	 : !(defined $rest || @$argv > 0) ) {
>	# Complain if this option needs an argument.
>#	if ( $mand && !($type eq 's' ? defined($optarg) : 0) ) {
>	if ( $mand ) {
>	    return (0) if $passthrough;
>	    warn ("Option ", $opt, " requires an argument\n");
>	    $error++;
>	    return (1, undef);
>	}
>	if ( $type eq 'I' ) {
>	    # Fake incremental type.
>	    my @c = @$ctl;
>	    $c[CTL_TYPE] = '+';
>	    return (1, $opt, \@c, 1);
>	}
>	return (1, $opt, $ctl,
>		defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
>		$type eq 's' ? '' : 0);
>    }
>
>    # Get (possibly optional) argument.
>    $arg = (defined $rest ? $rest
>	    : (defined $optarg ? $optarg : shift (@$argv)));
>
>    # Get key if this is a "name=value" pair for a hash option.
>    my $key;
>    if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
>	($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
>	  : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
>	     ($mand ? undef : ($type eq 's' ? "" : 1)));
>	if (! defined $arg) {
>	    warn ("Option $opt, key \"$key\", requires a value\n");
>	    $error++;
>	    # Push back.
>	    unshift (@$argv, $starter.$rest) if defined $rest;
>	    return (1, undef);
>	}
>    }
>
>    #### Check if the argument is valid for this option ####
>
>    my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
>
>    if ( $type eq 's' ) {	# string
>	# A mandatory string takes anything.
>	return (1, $opt, $ctl, $arg, $key) if $mand;
>
>	# Same for optional string as a hash value
>	return (1, $opt, $ctl, $arg, $key)
>	  if $ctl->[CTL_DEST] == CTL_DEST_HASH;
>
>	# An optional string takes almost anything.
>	return (1, $opt, $ctl, $arg, $key)
>	  if defined $optarg || defined $rest;
>	return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
>
>	# Check for option or option list terminator.
>	if ($arg eq $argend ||
>	    $arg =~ /^$prefix.+/) {
>	    # Push back.
>	    unshift (@$argv, $arg);
>	    # Supply empty value.
>	    $arg = '';
>	}
>    }
>
>    elsif ( $type eq 'i'	# numeric/integer
>            || $type eq 'I'	# numeric/integer w/ incr default
>	    || $type eq 'o' ) { # dec/oct/hex/bin value
>
>	my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
>
>	if ( $bundling && defined $rest
>	     && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
>	    ($key, $arg, $rest) = ($1, $2, $+);
>	    chop($key) if $key;
>	    $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
>	    unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
>	}
>	elsif ( $arg =~ /^$o_valid$/si ) {
>	    $arg =~ tr/_//d;
>	    $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
>	}
>	else {
>	    if ( defined $optarg || $mand ) {
>		if ( $passthrough ) {
>		    unshift (@$argv, defined $rest ? $starter.$rest : $arg)
>		      unless defined $optarg;
>		    return (0);
>		}
>		warn ("Value \"", $arg, "\" invalid for option ",
>		      $opt, " (",
>		      $type eq 'o' ? "extended " : '',
>		      "number expected)\n");
>		$error++;
>		# Push back.
>		unshift (@$argv, $starter.$rest) if defined $rest;
>		return (1, undef);
>	    }
>	    else {
>		# Push back.
>		unshift (@$argv, defined $rest ? $starter.$rest : $arg);
>		if ( $type eq 'I' ) {
>		    # Fake incremental type.
>		    my @c = @$ctl;
>		    $c[CTL_TYPE] = '+';
>		    return (1, $opt, \@c, 1);
>		}
>		# Supply default value.
>		$arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
>	    }
>	}
>    }
>
>    elsif ( $type eq 'f' ) { # real number, int is also ok
>	my $o_valid = PAT_FLOAT;
>	if ( $bundling && defined $rest &&
>	     $rest =~ /^($key_valid)($o_valid)(.*)$/s ) {
>	    $arg =~ tr/_//d;
>	    ($key, $arg, $rest) = ($1, $2, $+);
>	    chop($key) if $key;
>	    unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
>	}
>	elsif ( $arg =~ /^$o_valid$/ ) {
>	    $arg =~ tr/_//d;
>	}
>	else {
>	    if ( defined $optarg || $mand ) {
>		if ( $passthrough ) {
>		    unshift (@$argv, defined $rest ? $starter.$rest : $arg)
>		      unless defined $optarg;
>		    return (0);
>		}
>		warn ("Value \"", $arg, "\" invalid for option ",
>		      $opt, " (real number expected)\n");
>		$error++;
>		# Push back.
>		unshift (@$argv, $starter.$rest) if defined $rest;
>		return (1, undef);
>	    }
>	    else {
>		# Push back.
>		unshift (@$argv, defined $rest ? $starter.$rest : $arg);
>		# Supply default value.
>		$arg = 0.0;
>	    }
>	}
>    }
>    else {
>	die("Getopt::Long internal error (Can't happen)\n");
>    }
>    return (1, $opt, $ctl, $arg, $key);
>}
>
>sub ValidValue ($$$$$) {
>    my ($ctl, $arg, $mand, $argend, $prefix) = @_;
>
>    if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
>	return 0 unless $arg =~ /[^=]+=(.*)/;
>	$arg = $1;
>    }
>
>    my $type = $ctl->[CTL_TYPE];
>
>    if ( $type eq 's' ) {	# string
>	# A mandatory string takes anything.
>	return (1) if $mand;
>
>	return (1) if $arg eq "-";
>
>	# Check for option or option list terminator.
>	return 0 if $arg eq $argend || $arg =~ /^$prefix.+/;
>	return 1;
>    }
>
>    elsif ( $type eq 'i'	# numeric/integer
>            || $type eq 'I'	# numeric/integer w/ incr default
>	    || $type eq 'o' ) { # dec/oct/hex/bin value
>
>	my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
>	return $arg =~ /^$o_valid$/si;
>    }
>
>    elsif ( $type eq 'f' ) { # real number, int is also ok
>	my $o_valid = PAT_FLOAT;
>	return $arg =~ /^$o_valid$/;
>    }
>    die("ValidValue: Cannot happen\n");
>}
>
># Getopt::Long Configuration.
>sub Configure (@) {
>    my (@options) = @_;
>
>    my $prevconfig =
>      [ $error, $debug, $major_version, $minor_version, $caller,
>	$autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
>	$gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
>	$longprefix, $bundling_values ];
>
>    if ( ref($options[0]) eq 'ARRAY' ) {
>	( $error, $debug, $major_version, $minor_version, $caller,
>	  $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
>	  $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
>	  $longprefix, $bundling_values ) = @{shift(@options)};
>    }
>
>    my $opt;
>    foreach $opt ( @options ) {
>	my $try = lc ($opt);
>	my $action = 1;
>	if ( $try =~ /^no_?(.*)$/s ) {
>	    $action = 0;
>	    $try = $+;
>	}
>	if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
>	    ConfigDefaults ();
>	}
>	elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
>	    local $ENV{POSIXLY_CORRECT};
>	    $ENV{POSIXLY_CORRECT} = 1 if $action;
>	    ConfigDefaults ();
>	}
>	elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
>	    $autoabbrev = $action;
>	}
>	elsif ( $try eq 'getopt_compat' ) {
>	    $getopt_compat = $action;
>            $genprefix = $action ? "(--|-|\\+)" : "(--|-)";
>	}
>	elsif ( $try eq 'gnu_getopt' ) {
>	    if ( $action ) {
>		$gnu_compat = 1;
>		$bundling = 1;
>		$getopt_compat = 0;
>                $genprefix = "(--|-)";
>		$order = $PERMUTE;
>		$bundling_values = 0;
>	    }
>	}
>	elsif ( $try eq 'gnu_compat' ) {
>	    $gnu_compat = $action;
>	    $bundling = 0;
>	    $bundling_values = 1;
>	}
>	elsif ( $try =~ /^(auto_?)?version$/ ) {
>	    $auto_version = $action;
>	}
>	elsif ( $try =~ /^(auto_?)?help$/ ) {
>	    $auto_help = $action;
>	}
>	elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
>	    $ignorecase = $action;
>	}
>	elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) {
>	    $ignorecase = $action ? 2 : 0;
>	}
>	elsif ( $try eq 'bundling' ) {
>	    $bundling = $action;
>	    $bundling_values = 0 if $action;
>	}
>	elsif ( $try eq 'bundling_override' ) {
>	    $bundling = $action ? 2 : 0;
>	    $bundling_values = 0 if $action;
>	}
>	elsif ( $try eq 'bundling_values' ) {
>	    $bundling_values = $action;
>	    $bundling = 0 if $action;
>	}
>	elsif ( $try eq 'require_order' ) {
>	    $order = $action ? $REQUIRE_ORDER : $PERMUTE;
>	}
>	elsif ( $try eq 'permute' ) {
>	    $order = $action ? $PERMUTE : $REQUIRE_ORDER;
>	}
>	elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
>	    $passthrough = $action;
>	}
>	elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
>	    $genprefix = $1;
>	    # Turn into regexp. Needs to be parenthesized!
>	    $genprefix = "(" . quotemeta($genprefix) . ")";
>	    eval { '' =~ /$genprefix/; };
>	    die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@;
>	}
>	elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
>	    $genprefix = $1;
>	    # Parenthesize if needed.
>	    $genprefix = "(" . $genprefix . ")"
>	      unless $genprefix =~ /^$.*$$/;
>	    eval { '' =~ m"$genprefix"; };
>	    die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@;
>	}
>	elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) {
>	    $longprefix = $1;
>	    # Parenthesize if needed.
>	    $longprefix = "(" . $longprefix . ")"
>	      unless $longprefix =~ /^$.*$$/;
>	    eval { '' =~ m"$longprefix"; };
>	    die("Getopt::Long: invalid long prefix pattern \"$longprefix\"\n") if $@;
>	}
>	elsif ( $try eq 'debug' ) {
>	    $debug = $action;
>	}
>	else {
>	    die("Getopt::Long: unknown or erroneous config parameter \"$opt\"\n")
>	}
>    }
>    $prevconfig;
>}
>
># Deprecated name.
>sub config (@) {
>    Configure (@_);
>}
>
># Issue a standard message for --version.
>#
># The arguments are mostly the same as for Pod::Usage::pod2usage:
>#
>#  - a number (exit value)
>#  - a string (lead in message)
>#  - a hash with options. See Pod::Usage for details.
>#
>sub VersionMessage(@) {
>    # Massage args.
>    my $pa = setup_pa_args("version", @_);
>
>    my $v = $main::VERSION;
>    my $fh = $pa->{-output} ||
>      ( ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR );
>
>    print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
>	       $0, defined $v ? " version $v" : (),
>	       "\n",
>	       "(", __PACKAGE__, "::", "GetOptions",
>	       " version ",
>	       defined($Getopt::Long::VERSION_STRING)
>	         ? $Getopt::Long::VERSION_STRING : $VERSION, ";",
>	       " Perl version ",
>	       $] >= 5.006 ? sprintf("%vd", $^V) : $],
>	       ")\n");
>    exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT";
>}
>
># Issue a standard message for --help.
>#
># The arguments are the same as for Pod::Usage::pod2usage:
>#
>#  - a number (exit value)
>#  - a string (lead in message)
>#  - a hash with options. See Pod::Usage for details.
>#
>sub HelpMessage(@) {
>    eval {
>	require Pod::Usage;
>	import Pod::Usage;
>	1;
>    } || die("Cannot provide help: cannot load Pod::Usage\n");
>
>    # Note that pod2usage will issue a warning if -exitval => NOEXIT.
>    pod2usage(setup_pa_args("help", @_));
>
>}
>
># Helper routine to set up a normalized hash ref to be used as
># argument to pod2usage.
>sub setup_pa_args($@) {
>    my $tag = shift;		# who's calling
>
>    # If called by direct binding to an option, it will get the option
>    # name and value as arguments. Remove these, if so.
>    @_ = () if @_ == 2 && $_[0] eq $tag;
>
>    my $pa;
>    if ( @_ > 1 ) {
>	$pa = { @_ };
>    }
>    else {
>	$pa = shift || {};
>    }
>
>    # At this point, $pa can be a number (exit value), string
>    # (message) or hash with options.
>
>    if ( UNIVERSAL::isa($pa, 'HASH') ) {
>	# Get rid of -msg vs. -message ambiguity.
>	$pa->{-message} = $pa->{-msg};
>	delete($pa->{-msg});
>    }
>    elsif ( $pa =~ /^-?\d+$/ ) {
>	$pa = { -exitval => $pa };
>    }
>    else {
>	$pa = { -message => $pa };
>    }
>
>    # These are _our_ defaults.
>    $pa->{-verbose} = 0 unless exists($pa->{-verbose});
>    $pa->{-exitval} = 0 unless exists($pa->{-exitval});
>    $pa;
>}
>
># Sneak way to know what version the user requested.
>sub VERSION {
>    $requested_version = $_[1];
>    shift->SUPER::VERSION(@_);
>}
>
>package Getopt::Long::CallBack;
>
>sub new {
>    my ($pkg, %atts) = @_;
>    bless { %atts }, $pkg;
>}
>
>sub name {
>    my $self = shift;
>    ''.$self->{name};
>}
>
>use overload
>  # Treat this object as an ordinary string for legacy API.
>  '""'	   => \&name,
>  fallback => 1;
>
>1;
>
>################ Documentation ################
>
>=head1 NAME
>
>Getopt::Long - Extended processing of command line options
>
>=head1 SYNOPSIS
>
>  use Getopt::Long;
>  my $data   = "file.dat";
>  my $length = 24;
>  my $verbose;
>  GetOptions ("length=i" => \$length,    # numeric
>              "file=s"   => \$data,      # string
>              "verbose"  => \$verbose)   # flag
>  or die("Error in command line arguments\n");
>
>=head1 DESCRIPTION
>
>The Getopt::Long module implements an extended getopt function called
>GetOptions(). It parses the command line from C<@ARGV>, recognizing
>and removing specified options and their possible values.
>
>This function adheres to the POSIX syntax for command
>line options, with GNU extensions. In general, this means that options
>have long names instead of single letters, and are introduced with a
>double dash "--". Support for bundling of command line options, as was
>the case with the more traditional single-letter approach, is provided
>but not enabled by default.
>
>=head1 Command Line Options, an Introduction
>
>Command line operated programs traditionally take their arguments from
>the command line, for example filenames or other information that the
>program needs to know. Besides arguments, these programs often take
>command line I<options> as well. Options are not necessary for the
>program to work, hence the name 'option', but are used to modify its
>default behaviour. For example, a program could do its job quietly,
>but with a suitable option it could provide verbose information about
>what it did.
>
>Command line options come in several flavours. Historically, they are
>preceded by a single dash C<->, and consist of a single letter.
>
>    -l -a -c
>
>Usually, these single-character options can be bundled:
>
>    -lac
>
>Options can have values, the value is placed after the option
>character. Sometimes with whitespace in between, sometimes not:
>
>    -s 24 -s24
>
>Due to the very cryptic nature of these options, another style was
>developed that used long names. So instead of a cryptic C<-l> one
>could use the more descriptive C<--long>. To distinguish between a
>bundle of single-character options and a long one, two dashes are used
>to precede the option name. Early implementations of long options used
>a plus C<+> instead. Also, option values could be specified either
>like
>
>    --size=24
>
>or
>
>    --size 24
>
>The C<+> form is now obsolete and strongly deprecated.
>
>=head1 Getting Started with Getopt::Long
>
>Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was the
>first Perl module that provided support for handling the new style of
>command line options, in particular long option names, hence the Perl5
>name Getopt::Long. This module also supports single-character options
>and bundling.
>
>To use Getopt::Long from a Perl program, you must include the
>following line in your Perl program:
>
>    use Getopt::Long;
>
>This will load the core of the Getopt::Long module and prepare your
>program for using it. Most of the actual Getopt::Long code is not
>loaded until you really call one of its functions.
>
>In the default configuration, options names may be abbreviated to
>uniqueness, case does not matter, and a single dash is sufficient,
>even for long option names. Also, options may be placed between
>non-option arguments. See L<Configuring Getopt::Long> for more
>details on how to configure Getopt::Long.
>
>=head2 Simple options
>
>The most simple options are the ones that take no values. Their mere
>presence on the command line enables the option. Popular examples are:
>
>    --all --verbose --quiet --debug
>
>Handling simple options is straightforward:
>
>    my $verbose = '';	# option variable with default value (false)
>    my $all = '';	# option variable with default value (false)
>    GetOptions ('verbose' => \$verbose, 'all' => \$all);
>
>The call to GetOptions() parses the command line arguments that are
>present in C<@ARGV> and sets the option variable to the value C<1> if
>the option did occur on the command line. Otherwise, the option
>variable is not touched. Setting the option value to true is often
>called I<enabling> the option.
>
>The option name as specified to the GetOptions() function is called
>the option I<specification>. Later we'll see that this specification
>can contain more than just the option name. The reference to the
>variable is called the option I<destination>.
>
>GetOptions() will return a true value if the command line could be
>processed successfully. Otherwise, it will write error messages using
>die() and warn(), and return a false result.
>
>=head2 A little bit less simple options
>
>Getopt::Long supports two useful variants of simple options:
>I<negatable> options and I<incremental> options.
>
>A negatable option is specified with an exclamation mark C<!> after the
>option name:
>
>    my $verbose = '';	# option variable with default value (false)
>    GetOptions ('verbose!' => \$verbose);
>
>Now, using C<--verbose> on the command line will enable C<$verbose>,
>as expected. But it is also allowed to use C<--noverbose>, which will
>disable C<$verbose> by setting its value to C<0>. Using a suitable
>default value, the program can find out whether C<$verbose> is false
>by default, or disabled by using C<--noverbose>.
>
>An incremental option is specified with a plus C<+> after the
>option name:
>
>    my $verbose = '';	# option variable with default value (false)
>    GetOptions ('verbose+' => \$verbose);
>
>Using C<--verbose> on the command line will increment the value of
>C<$verbose>. This way the program can keep track of how many times the
>option occurred on the command line. For example, each occurrence of
>C<--verbose> could increase the verbosity level of the program.
>
>=head2 Mixing command line option with other arguments
>
>Usually programs take command line options as well as other arguments,
>for example, file names. It is good practice to always specify the
>options first, and the other arguments last. Getopt::Long will,
>however, allow the options and arguments to be mixed and 'filter out'
>all the options before passing the rest of the arguments to the
>program. To stop Getopt::Long from processing further arguments,
>insert a double dash C<--> on the command line:
>
>    --size 24 -- --all
>
>In this example, C<--all> will I<not> be treated as an option, but
>passed to the program unharmed, in C<@ARGV>.
>
>=head2 Options with values
>
>For options that take values it must be specified whether the option
>value is required or not, and what kind of value the option expects.
>
>Three kinds of values are supported: integer numbers, floating point
>numbers, and strings.
>
>If the option value is required, Getopt::Long will take the
>command line argument that follows the option and assign this to the
>option variable. If, however, the option value is specified as
>optional, this will only be done if that value does not look like a
>valid command line option itself.
>
>    my $tag = '';	# option variable with default value
>    GetOptions ('tag=s' => \$tag);
>
>In the option specification, the option name is followed by an equals
>sign C<=> and the letter C<s>. The equals sign indicates that this
>option requires a value. The letter C<s> indicates that this value is
>an arbitrary string. Other possible value types are C<i> for integer
>values, and C<f> for floating point values. Using a colon C<:> instead
>of the equals sign indicates that the option value is optional. In
>this case, if no suitable value is supplied, string valued options get
>an empty string C<''> assigned, while numeric options are set to C<0>.
>
>=head2 Options with multiple values
>
>Options sometimes take several values. For example, a program could
>use multiple directories to search for library files:
>
>    --library lib/stdlib --library lib/extlib
>
>To accomplish this behaviour, simply specify an array reference as the
>destination for the option:
>
>    GetOptions ("library=s" => \@libfiles);
>
>Alternatively, you can specify that the option can have multiple
>values by adding a "@", and pass a scalar reference as the
>destination:
>
>    GetOptions ("library=s@" => \$libfiles);
>
>Used with the example above, C<@libfiles> (or C<@$libfiles>) would
>contain two strings upon completion: C<"lib/stdlib"> and
>C<"lib/extlib">, in that order. It is also possible to specify that
>only integer or floating point numbers are acceptable values.
>
>Often it is useful to allow comma-separated lists of values as well as
>multiple occurrences of the options. This is easy using Perl's split()
>and join() operators:
>
>    GetOptions ("library=s" => \@libfiles);
>    @libfiles = split(/,/,join(',',@libfiles));
>
>Of course, it is important to choose the right separator string for
>each purpose.
>
>Warning: What follows is an experimental feature.
>
>Options can take multiple values at once, for example
>
>    --coordinates 52.2 16.4 --rgbcolor 255 255 149
>
>This can be accomplished by adding a repeat specifier to the option
>specification. Repeat specifiers are very similar to the C<{...}>
>repeat specifiers that can be used with regular expression patterns.
>For example, the above command line would be handled as follows:
>
>    GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color);
>
>The destination for the option must be an array or array reference.
>
>It is also possible to specify the minimal and maximal number of
>arguments an option takes. C<foo=s{2,4}> indicates an option that
>takes at least two and at most 4 arguments. C<foo=s{1,}> indicates one
>or more values; C<foo:s{,}> indicates zero or more option values.
>
>=head2 Options with hash values
>
>If the option destination is a reference to a hash, the option will
>take, as value, strings of the form I<key>C<=>I<value>. The value will
>be stored with the specified key in the hash.
>
>    GetOptions ("define=s" => \%defines);
>
>Alternatively you can use:
>
>    GetOptions ("define=s%" => \$defines);
>
>When used with command line options:
>
>    --define os=linux --define vendor=redhat
>
>the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os">
>with value C<"linux"> and C<"vendor"> with value C<"redhat">. It is
>also possible to specify that only integer or floating point numbers
>are acceptable values. The keys are always taken to be strings.
>
>=head2 User-defined subroutines to handle options
>
>Ultimate control over what should be done when (actually: each time)
>an option is encountered on the command line can be achieved by
>designating a reference to a subroutine (or an anonymous subroutine)
>as the option destination. When GetOptions() encounters the option, it
>will call the subroutine with two or three arguments. The first
>argument is the name of the option. (Actually, it is an object that
>stringifies to the name of the option.) For a scalar or array destination,
>the second argument is the value to be stored. For a hash destination,
>the second argument is the key to the hash, and the third argument
>the value to be stored. It is up to the subroutine to store the value,
>or do whatever it thinks is appropriate.
>
>A trivial application of this mechanism is to implement options that
>are related to each other. For example:
>
>    my $verbose = '';	# option variable with default value (false)
>    GetOptions ('verbose' => \$verbose,
>	        'quiet'   => sub { $verbose = 0 });
>
>Here C<--verbose> and C<--quiet> control the same variable
>C<$verbose>, but with opposite values.
>
>If the subroutine needs to signal an error, it should call die() with
>the desired error message as its argument. GetOptions() will catch the
>die(), issue the error message, and record that an error result must
>be returned upon completion.
>
>If the text of the error message starts with an exclamation mark C<!>
>it is interpreted specially by GetOptions(). There is currently one
>special command implemented: C<die("!FINISH")> will cause GetOptions()
>to stop processing options, as if it encountered a double dash C<-->.
>
>In version 2.37 the first argument to the callback function was
>changed from string to object. This was done to make room for
>extensions and more detailed control. The object stringifies to the
>option name so this change should not introduce compatibility
>problems.
>
>Here is an example of how to access the option name and value from within
>a subroutine:
>
>    GetOptions ('opt=i' => \&handler);
>    sub handler {
>        my ($opt_name, $opt_value) = @_;
>        print("Option name is $opt_name and value is $opt_value\n");
>    }
>
>=head2 Options with multiple names
>
>Often it is user friendly to supply alternate mnemonic names for
>options. For example C<--height> could be an alternate name for
>C<--length>. Alternate names can be included in the option
>specification, separated by vertical bar C<|> characters. To implement
>the above example:
>
>    GetOptions ('length|height=f' => \$length);
>
>The first name is called the I<primary> name, the other names are
>called I<aliases>. When using a hash to store options, the key will
>always be the primary name.
>
>Multiple alternate names are possible.
>
>=head2 Case and abbreviations
>
>Without additional configuration, GetOptions() will ignore the case of
>option names, and allow the options to be abbreviated to uniqueness.
>
>    GetOptions ('length|height=f' => \$length, "head" => \$head);
>
>This call will allow C<--l> and C<--L> for the length option, but
>requires a least C<--hea> and C<--hei> for the head and height options.
>
>=head2 Summary of Option Specifications
>
>Each option specifier consists of two parts: the name specification
>and the argument specification.
>
>The name specification contains the name of the option, optionally
>followed by a list of alternative names separated by vertical bar
>characters.
>
>    length	      option name is "length"
>    length|size|l     name is "length", aliases are "size" and "l"
>
>The argument specification is optional. If omitted, the option is
>considered boolean, a value of 1 will be assigned when the option is
>used on the command line.
>
>The argument specification can be
>
>=over 4
>
>=item !
>
>The option does not take an argument and may be negated by prefixing
>it with "no" or "no-". E.g. C<"foo!"> will allow C<--foo> (a value of
>1 will be assigned) as well as C<--nofoo> and C<--no-foo> (a value of
>0 will be assigned). If the option has aliases, this applies to the
>aliases as well.
>
>Using negation on a single letter option when bundling is in effect is
>pointless and will result in a warning.
>
>=item +
>
>The option does not take an argument and will be incremented by 1
>every time it appears on the command line. E.g. C<"more+">, when used
>with C<--more --more --more>, will increment the value three times,
>resulting in a value of 3 (provided it was 0 or undefined at first).
>
>The C<+> specifier is ignored if the option destination is not a scalar.
>
>=item = I<type> [ I<desttype> ] [ I<repeat> ]
>
>The option requires an argument of the given type. Supported types
>are:
>
>=over 4
>
>=item s
>
>String. An arbitrary sequence of characters. It is valid for the
>argument to start with C<-> or C<-->.
>
>=item i
>
>Integer. An optional leading plus or minus sign, followed by a
>sequence of digits.
>
>=item o
>
>Extended integer, Perl style. This can be either an optional leading
>plus or minus sign, followed by a sequence of digits, or an octal
>string (a zero, optionally followed by '0', '1', .. '7'), or a
>hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case
>insensitive), or a binary string (C<0b> followed by a series of '0'
>and '1').
>
>=item f
>
>Real number. For example C<3.14>, C<-6.23E24> and so on.
>
>=back
>
>The I<desttype> can be C<@> or C<%> to specify that the option is
>list or a hash valued. This is only needed when the destination for
>the option value is not otherwise specified. It should be omitted when
>not needed.
>
>The I<repeat> specifies the number of values this option takes per
>occurrence on the command line. It has the format C<{> [ I<min> ] [ C<,> [ I<max> ] ] C<}>.
>
>I<min> denotes the minimal number of arguments. It defaults to 1 for
>options with C<=> and to 0 for options with C<:>, see below. Note that
>I<min> overrules the C<=> / C<:> semantics.
>
>I<max> denotes the maximum number of arguments. It must be at least
>I<min>. If I<max> is omitted, I<but the comma is not>, there is no
>upper bound to the number of argument values taken.
>
>=item : I<type> [ I<desttype> ]
>
>Like C<=>, but designates the argument as optional.
>If omitted, an empty string will be assigned to string values options,
>and the value zero to numeric options.
>
>Note that if a string argument starts with C<-> or C<-->, it will be
>considered an option on itself.
>
>=item : I<number> [ I<desttype> ]
>
>Like C<:i>, but if the value is omitted, the I<number> will be assigned.
>
>=item : + [ I<desttype> ]
>
>Like C<:i>, but if the value is omitted, the current value for the
>option will be incremented.
>
>=back
>
>=head1 Advanced Possibilities
>
>=head2 Object oriented interface
>
>Getopt::Long can be used in an object oriented way as well:
>
>    use Getopt::Long;
>    $p = Getopt::Long::Parser->new;
>    $p->configure(...configuration options...);
>    if ($p->getoptions(...options descriptions...)) ...
>    if ($p->getoptionsfromarray( \@array, ...options descriptions...)) ...
>
>Configuration options can be passed to the constructor:
>
>    $p = new Getopt::Long::Parser
>             config => [...configuration options...];
>
>=head2 Thread Safety
>
>Getopt::Long is thread safe when using ithreads as of Perl 5.8.  It is
>I<not> thread safe when using the older (experimental and now
>obsolete) threads implementation that was added to Perl 5.005.
>
>=head2 Documentation and help texts
>
>Getopt::Long encourages the use of Pod::Usage to produce help
>messages. For example:
>
>    use Getopt::Long;
>    use Pod::Usage;
>
>    my $man = 0;
>    my $help = 0;
>
>    GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
>    pod2usage(1) if $help;
>    pod2usage(-exitval => 0, -verbose => 2) if $man;
>
>    __END__
>
>    =head1 NAME
>
>    sample - Using Getopt::Long and Pod::Usage
>
>    =head1 SYNOPSIS
>
>    sample [options] [file ...]
>
>     Options:
>       -help            brief help message
>       -man             full documentation
>
>    =head1 OPTIONS
>
>    =over 8
>
>    =item B<-help>
>
>    Print a brief help message and exits.
>
>    =item B<-man>
>
>    Prints the manual page and exits.
>
>    =back
>
>    =head1 DESCRIPTION
>
>    B<This program> will read the given input file(s) and do something
>    useful with the contents thereof.
>
>    =cut
>
>See L<Pod::Usage> for details.
>
>=head2 Parsing options from an arbitrary array
>
>By default, GetOptions parses the options that are present in the
>global array C<@ARGV>. A special entry C<GetOptionsFromArray> can be
>used to parse options from an arbitrary array.
>
>    use Getopt::Long qw(GetOptionsFromArray);
>    $ret = GetOptionsFromArray(\@myopts, ...);
>
>When used like this, options and their possible values are removed
>from C<@myopts>, the global C<@ARGV> is not touched at all.
>
>The following two calls behave identically:
>
>    $ret = GetOptions( ... );
>    $ret = GetOptionsFromArray(\@ARGV, ... );
>
>This also means that a first argument hash reference now becomes the
>second argument:
>
>    $ret = GetOptions(\%opts, ... );
>    $ret = GetOptionsFromArray(\@ARGV, \%opts, ... );
>
>=head2 Parsing options from an arbitrary string
>
>A special entry C<GetOptionsFromString> can be used to parse options
>from an arbitrary string.
>
>    use Getopt::Long qw(GetOptionsFromString);
>    $ret = GetOptionsFromString($string, ...);
>
>The contents of the string are split into arguments using a call to
>C<Text::ParseWords::shellwords>. As with C<GetOptionsFromArray>, the
>global C<@ARGV> is not touched.
>
>It is possible that, upon completion, not all arguments in the string
>have been processed. C<GetOptionsFromString> will, when called in list
>context, return both the return status and an array reference to any
>remaining arguments:
>
>    ($ret, $args) = GetOptionsFromString($string, ... );
>
>If any arguments remain, and C<GetOptionsFromString> was not called in
>list context, a message will be given and C<GetOptionsFromString> will
>return failure.
>
>As with GetOptionsFromArray, a first argument hash reference now
>becomes the second argument.
>
>=head2 Storing options values in a hash
>
>Sometimes, for example when there are a lot of options, having a
>separate variable for each of them can be cumbersome. GetOptions()
>supports, as an alternative mechanism, storing options values in a
>hash.
>
>To obtain this, a reference to a hash must be passed I<as the first
>argument> to GetOptions(). For each option that is specified on the
>command line, the option value will be stored in the hash with the
>option name as key. Options that are not actually used on the command
>line will not be put in the hash, on other words,
>C<exists($h{option})> (or defined()) can be used to test if an option
>was used. The drawback is that warnings will be issued if the program
>runs under C<use strict> and uses C<$h{option}> without testing with
>exists() or defined() first.
>
>    my %h = ();
>    GetOptions (\%h, 'length=i');	# will store in $h{length}
>
>For options that take list or hash values, it is necessary to indicate
>this by appending an C<@> or C<%> sign after the type:
>
>    GetOptions (\%h, 'colours=s@');	# will push to @{$h{colours}}
>
>To make things more complicated, the hash may contain references to
>the actual destinations, for example:
>
>    my $len = 0;
>    my %h = ('length' => \$len);
>    GetOptions (\%h, 'length=i');	# will store in $len
>
>This example is fully equivalent with:
>
>    my $len = 0;
>    GetOptions ('length=i' => \$len);	# will store in $len
>
>Any mixture is possible. For example, the most frequently used options
>could be stored in variables while all other options get stored in the
>hash:
>
>    my $verbose = 0;			# frequently referred
>    my $debug = 0;			# frequently referred
>    my %h = ('verbose' => \$verbose, 'debug' => \$debug);
>    GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i');
>    if ( $verbose ) { ... }
>    if ( exists $h{filter} ) { ... option 'filter' was specified ... }
>
>=head2 Bundling
>
>With bundling it is possible to set several single-character options
>at once. For example if C<a>, C<v> and C<x> are all valid options,
>
>    -vax
>
>will set all three.
>
>Getopt::Long supports three styles of bundling. To enable bundling, a
>call to Getopt::Long::Configure is required.
>
>The simplest style of bundling can be enabled with:
>
>    Getopt::Long::Configure ("bundling");
>
>Configured this way, single-character options can be bundled but long
>options B<must> always start with a double dash C<--> to avoid
>ambiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid
>options,
>
>    -vax
>
>will set C<a>, C<v> and C<x>, but
>
>    --vax
>
>will set C<vax>.
>
>The second style of bundling lifts this restriction. It can be enabled
>with:
>
>    Getopt::Long::Configure ("bundling_override");
>
>Now, C<-vax> will set the option C<vax>.
>
>In all of the above cases, option values may be inserted in the
>bundle. For example:
>
>    -h24w80
>
>is equivalent to
>
>    -h 24 -w 80
>
>A third style of bundling allows only values to be bundled with
>options. It can be enabled with:
>
>    Getopt::Long::Configure ("bundling_values");
>
>Now, C<-h24> will set the option C<h> to C<24>, but option bundles
>like C<-vxa> and C<-h24w80> are flagged as errors.
>
>Enabling C<bundling_values> will disable the other two styles of
>bundling.
>
>When configured for bundling, single-character options are matched
>case sensitive while long options are matched case insensitive. To
>have the single-character options matched case insensitive as well,
>use:
>
>    Getopt::Long::Configure ("bundling", "ignorecase_always");
>
>It goes without saying that bundling can be quite confusing.
>
>=head2 The lonesome dash
>
>Normally, a lone dash C<-> on the command line will not be considered
>an option. Option processing will terminate (unless "permute" is
>configured) and the dash will be left in C<@ARGV>.
>
>It is possible to get special treatment for a lone dash. This can be
>achieved by adding an option specification with an empty name, for
>example:
>
>    GetOptions ('' => \$stdio);
>
>A lone dash on the command line will now be a legal option, and using
>it will set variable C<$stdio>.
>
>=head2 Argument callback
>
>A special option 'name' C<< <> >> can be used to designate a subroutine
>to handle non-option arguments. When GetOptions() encounters an
>argument that does not look like an option, it will immediately call this
>subroutine and passes it one parameter: the argument name. Well, actually
>it is an object that stringifies to the argument name.
>
>For example:
>
>    my $width = 80;
>    sub process { ... }
>    GetOptions ('width=i' => \$width, '<>' => \&process);
>
>When applied to the following command line:
>
>    arg1 --width=72 arg2 --width=60 arg3
>
>This will call
>C<process("arg1")> while C<$width> is C<80>,
>C<process("arg2")> while C<$width> is C<72>, and
>C<process("arg3")> while C<$width> is C<60>.
>
>This feature requires configuration option B<permute>, see section
>L<Configuring Getopt::Long>.
>
>=head1 Configuring Getopt::Long
>
>Getopt::Long can be configured by calling subroutine
>Getopt::Long::Configure(). This subroutine takes a list of quoted
>strings, each specifying a configuration option to be enabled, e.g.
>C<ignore_case>, or disabled, e.g. C<no_ignore_case>. Case does not
>matter. Multiple calls to Configure() are possible.
>
>Alternatively, as of version 2.24, the configuration options may be
>passed together with the C<use> statement:
>
>    use Getopt::Long qw(:config no_ignore_case bundling);
>
>The following options are available:
>
>=over 12
>
>=item default
>
>This option causes all configuration options to be reset to their
>default values.
>
>=item posix_default
>
>This option causes all configuration options to be reset to their
>default values as if the environment variable POSIXLY_CORRECT had
>been set.
>
>=item auto_abbrev
>
>Allow option names to be abbreviated to uniqueness.
>Default is enabled unless environment variable
>POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled.
>
>=item getopt_compat
>
>Allow C<+> to start options.
>Default is enabled unless environment variable
>POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled.
>
>=item gnu_compat
>
>C<gnu_compat> controls whether C<--opt=> is allowed, and what it should
>do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>,
>C<--opt=> will give option C<opt> and empty value.
>This is the way GNU getopt_long() does it.
>
>=item gnu_getopt
>
>This is a short way of setting C<gnu_compat> C<bundling> C<permute>
>C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be
>fully compatible with GNU getopt_long().
>
>=item require_order
>
>Whether command line arguments are allowed to be mixed with options.
>Default is disabled unless environment variable
>POSIXLY_CORRECT has been set, in which case C<require_order> is enabled.
>
>See also C<permute>, which is the opposite of C<require_order>.
>
>=item permute
>
>Whether command line arguments are allowed to be mixed with options.
>Default is enabled unless environment variable
>POSIXLY_CORRECT has been set, in which case C<permute> is disabled.
>Note that C<permute> is the opposite of C<require_order>.
>
>If C<permute> is enabled, this means that
>
>    --foo arg1 --bar arg2 arg3
>
>is equivalent to
>
>    --foo --bar arg1 arg2 arg3
>
>If an argument callback routine is specified, C<@ARGV> will always be
>empty upon successful return of GetOptions() since all options have been
>processed. The only exception is when C<--> is used:
>
>    --foo arg1 --bar arg2 -- arg3
>
>This will call the callback routine for arg1 and arg2, and then
>terminate GetOptions() leaving C<"arg3"> in C<@ARGV>.
>
>If C<require_order> is enabled, options processing
>terminates when the first non-option is encountered.
>
>    --foo arg1 --bar arg2 arg3
>
>is equivalent to
>
>    --foo -- arg1 --bar arg2 arg3
>
>If C<pass_through> is also enabled, options processing will terminate
>at the first unrecognized option, or non-option, whichever comes
>first.
>
>=item bundling (default: disabled)
>
>Enabling this option will allow single-character options to be
>bundled. To distinguish bundles from long option names, long options
>I<must> be introduced with C<--> and bundles with C<->.
>
>Note that, if you have options C<a>, C<l> and C<all>, and
>auto_abbrev enabled, possible arguments and option settings are:
>
>    using argument               sets option(s)
>    ------------------------------------------
>    -a, --a                      a
>    -l, --l                      l
>    -al, -la, -ala, -all,...     a, l
>    --al, --all                  all
>
>The surprising part is that C<--a> sets option C<a> (due to auto
>completion), not C<all>.
>
>Note: disabling C<bundling> also disables C<bundling_override>.
>
>=item bundling_override (default: disabled)
>
>If C<bundling_override> is enabled, bundling is enabled as with
>C<bundling> but now long option names override option bundles.
>
>Note: disabling C<bundling_override> also disables C<bundling>.
>
>B<Note:> Using option bundling can easily lead to unexpected results,
>especially when mixing long options and bundles. Caveat emptor.
>
>=item ignore_case  (default: enabled)
>
>If enabled, case is ignored when matching option names. If, however,
>bundling is enabled as well, single character options will be treated
>case-sensitive.
>
>With C<ignore_case>, option specifications for options that only
>differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as
>duplicates.
>
>Note: disabling C<ignore_case> also disables C<ignore_case_always>.
>
>=item ignore_case_always (default: disabled)
>
>When bundling is in effect, case is ignored on single-character
>options also.
>
>Note: disabling C<ignore_case_always> also disables C<ignore_case>.
>
>=item auto_version (default:disabled)
>
>Automatically provide support for the B<--version> option if
>the application did not specify a handler for this option itself.
>
>Getopt::Long will provide a standard version message that includes the
>program name, its version (if $main::VERSION is defined), and the
>versions of Getopt::Long and Perl. The message will be written to
>standard output and processing will terminate.
>
>C<auto_version> will be enabled if the calling program explicitly
>specified a version number higher than 2.32 in the C<use> or
>C<require> statement.
>
>=item auto_help (default:disabled)
>
>Automatically provide support for the B<--help> and B<-?> options if
>the application did not specify a handler for this option itself.
>
>Getopt::Long will provide a help message using module L<Pod::Usage>. The
>message, derived from the SYNOPSIS POD section, will be written to
>standard output and processing will terminate.
>
>C<auto_help> will be enabled if the calling program explicitly
>specified a version number higher than 2.32 in the C<use> or
>C<require> statement.
>
>=item pass_through (default: disabled)
>
>With C<pass_through> anything that is unknown, ambiguous or supplied with
>an invalid option will not be flagged as an error. Instead the unknown
>option(s) will be passed to the catchall C<< <> >> if present, otherwise
>through to C<@ARGV>. This makes it possible to write wrapper scripts that
>process only part of the user supplied command line arguments, and pass the
>remaining options to some other program.
>
>If C<require_order> is enabled, options processing will terminate at the
>first unrecognized option, or non-option, whichever comes first and all
>remaining arguments are passed to C<@ARGV> instead of the catchall
>C<< <> >> if present.  However, if C<permute> is enabled instead, results
>can become confusing.
>
>Note that the options terminator (default C<-->), if present, will
>also be passed through in C<@ARGV>.
>
>=item prefix
>
>The string that starts options. If a constant string is not
>sufficient, see C<prefix_pattern>.
>
>=item prefix_pattern
>
>A Perl pattern that identifies the strings that introduce options.
>Default is C<--|-|\+> unless environment variable
>POSIXLY_CORRECT has been set, in which case it is C<--|->.
>
>=item long_prefix_pattern
>
>A Perl pattern that allows the disambiguation of long and short
>prefixes. Default is C<-->.
>
>Typically you only need to set this if you are using nonstandard
>prefixes and want some or all of them to have the same semantics as
>'--' does under normal circumstances.
>
>For example, setting prefix_pattern to C<--|-|\+|\/> and
>long_prefix_pattern to C<--|\/> would add Win32 style argument
>handling.
>
>=item debug (default: disabled)
>
>Enable debugging output.
>
>=back
>
>=head1 Exportable Methods
>
>=over
>
>=item VersionMessage
>
>This subroutine provides a standard version message. Its argument can be:
>
>=over 4
>
>=item *
>
>A string containing the text of a message to print I<before> printing
>the standard message.
>
>=item *
>
>A numeric value corresponding to the desired exit status.
>
>=item *
>
>A reference to a hash.
>
>=back
>
>If more than one argument is given then the entire argument list is
>assumed to be a hash.  If a hash is supplied (either as a reference or
>as a list) it should contain one or more elements with the following
>keys:
>
>=over 4
>
>=item C<-message>
>
>=item C<-msg>
>
>The text of a message to print immediately prior to printing the
>program's usage message.
>
>=item C<-exitval>
>
>The desired exit status to pass to the B<exit()> function.
>This should be an integer, or else the string "NOEXIT" to
>indicate that control should simply be returned without
>terminating the invoking process.
>
>=item C<-output>
>
>A reference to a filehandle, or the pathname of a file to which the
>usage message should be written. The default is C<\*STDERR> unless the
>exit value is less than 2 (in which case the default is C<\*STDOUT>).
>
>=back
>
>You cannot tie this routine directly to an option, e.g.:
>
>    GetOptions("version" => \&VersionMessage);
>
>Use this instead:
>
>    GetOptions("version" => sub { VersionMessage() });
>
>=item HelpMessage
>
>This subroutine produces a standard help message, derived from the
>program's POD section SYNOPSIS using L<Pod::Usage>. It takes the same
>arguments as VersionMessage(). In particular, you cannot tie it
>directly to an option, e.g.:
>
>    GetOptions("help" => \&HelpMessage);
>
>Use this instead:
>
>    GetOptions("help" => sub { HelpMessage() });
>
>=back
>
>=head1 Return values and Errors
>
>Configuration errors and errors in the option definitions are
>signalled using die() and will terminate the calling program unless
>the call to Getopt::Long::GetOptions() was embedded in C<eval { ...
>}>, or die() was trapped using C<$SIG{__DIE__}>.
>
>GetOptions returns true to indicate success.
>It returns false when the function detected one or more errors during
>option parsing. These errors are signalled using warn() and can be
>trapped with C<$SIG{__WARN__}>.
>
>=head1 Legacy
>
>The earliest development of C<newgetopt.pl> started in 1990, with Perl
>version 4. As a result, its development, and the development of
>Getopt::Long, has gone through several stages. Since backward
>compatibility has always been extremely important, the current version
>of Getopt::Long still supports a lot of constructs that nowadays are
>no longer necessary or otherwise unwanted. This section describes
>briefly some of these 'features'.
>
>=head2 Default destinations
>
>When no destination is specified for an option, GetOptions will store
>the resultant value in a global variable named C<opt_>I<XXX>, where
>I<XXX> is the primary name of this option. When a program executes
>under C<use strict> (recommended), these variables must be
>pre-declared with our() or C<use vars>.
>
>    our $opt_length = 0;
>    GetOptions ('length=i');	# will store in $opt_length
>
>To yield a usable Perl variable, characters that are not part of the
>syntax for variables are translated to underscores. For example,
>C<--fpp-struct-return> will set the variable
>C<$opt_fpp_struct_return>. Note that this variable resides in the
>namespace of the calling program, not necessarily C<main>. For
>example:
>
>    GetOptions ("size=i", "sizes=i@");
>
>with command line "-size 10 -sizes 24 -sizes 48" will perform the
>equivalent of the assignments
>
>    $opt_size = 10;
>    @opt_sizes = (24, 48);
>
>=head2 Alternative option starters
>
>A string of alternative option starter characters may be passed as the
>first argument (or the first argument after a leading hash reference
>argument).
>
>    my $len = 0;
>    GetOptions ('/', 'length=i' => $len);
>
>Now the command line may look like:
>
>    /length 24 -- arg
>
>Note that to terminate options processing still requires a double dash
>C<-->.
>
>GetOptions() will not interpret a leading C<< "<>" >> as option starters
>if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as
>option starters, use C<< "><" >>. Confusing? Well, B<using a starter
>argument is strongly deprecated> anyway.
>
>=head2 Configuration variables
>
>Previous versions of Getopt::Long used variables for the purpose of
>configuring. Although manipulating these variables still work, it is
>strongly encouraged to use the C<Configure> routine that was introduced
>in version 2.17. Besides, it is much easier.
>
>=head1 Tips and Techniques
>
>=head2 Pushing multiple values in a hash option
>
>Sometimes you want to combine the best of hashes and arrays. For
>example, the command line:
>
>  --list add=first --list add=second --list add=third
>
>where each successive 'list add' option will push the value of add
>into array ref $list->{'add'}. The result would be like
>
>  $list->{add} = [qw(first second third)];
>
>This can be accomplished with a destination routine:
>
>  GetOptions('list=s%' =>
>               sub { push(@{$list{$_[1]}}, $_[2]) });
>
>=head1 Troubleshooting
>
>=head2 GetOptions does not return a false result when an option is not supplied
>
>That's why they're called 'options'.
>
>=head2 GetOptions does not split the command line correctly
>
>The command line is not split by GetOptions, but by the command line
>interpreter (CLI). On Unix, this is the shell. On Windows, it is
>COMMAND.COM or CMD.EXE. Other operating systems have other CLIs.
>
>It is important to know that these CLIs may behave different when the
>command line contains special characters, in particular quotes or
>backslashes. For example, with Unix shells you can use single quotes
>(C<'>) and double quotes (C<">) to group words together. The following
>alternatives are equivalent on Unix:
>
>    "two words"
>    'two words'
>    two\ words
>
>In case of doubt, insert the following statement in front of your Perl
>program:
>
>    print STDERR (join("|",@ARGV),"\n");
>
>to verify how your CLI passes the arguments to the program.
>
>=head2 Undefined subroutine &main::GetOptions called
>
>Are you running Windows, and did you write
>
>    use GetOpt::Long;
>
>(note the capital 'O')?
>
>=head2 How do I put a "-?" option into a Getopt::Long?
>
>You can only obtain this using an alias, and Getopt::Long of at least
>version 2.13.
>
>    use Getopt::Long;
>    GetOptions ("help|?");    # -help and -? will both set $opt_help
>
>Other characters that can't appear in Perl identifiers are also supported
>as aliases with Getopt::Long of at least version 2.39.
>
>As of version 2.32 Getopt::Long provides auto-help, a quick and easy way
>to add the options --help and -? to your program, and handle them.
>
>See C<auto_help> in section L<Configuring Getopt::Long>.
>
>=head1 AUTHOR
>
>Johan Vromans <jvromans@squirrel.nl>
>
>=head1 COPYRIGHT AND DISCLAIMER
>
>This program is Copyright 1990,2015 by Johan Vromans.
>This program is free software; you can redistribute it and/or
>modify it under the terms of the Perl Artistic License or 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.
>
>=cut
>

Actions: View

Attachments on bug 35523: 7922 | 7923 | 7924 | 7925 | 8165 | 8166 | 8167