File Coverage

blib/lib/Getopt/Tabular.pm

Criterion	Covered	Total	%
statement	104	273	38.1
branch	43	174	24.7
condition	5	67	7.4
subroutine	13	30	43.3
pod	0	26	0.0
total	165	570	28.9

package Getopt::Tabular;

#
# Getopt/Tabular.pm
#
# Perl module for table-driven argument parsing, somewhat like Tk's
# ParseArgv.  To use the package, you just have to set up an argument table
# (a list of array references), and call &GetOptions (the name is exported
# from the module).  &GetOptions takes two or three arguments; a reference
# to your argument table (which is not modified), a reference to the list
# of command line arguments, e.g. @ARGV (or a copy of it), and (optionally)
# a reference to a new empty array.  In the two argument form, the second
# argument is modified in place to remove all options and their arguments.
# In the three argument form, the second argument is unmodified, and the
# third argument is set to a copy of it with options removed.
#
# The argument table consists of one element per valid command-line option;
# each element should be a reference to a list of the form:
#
#    ( option_name, type, num_values, option_data, help_string, arg_desc )
#
# See Getopt/Tabular.pod for complete information.
#
# originally by Greg Ward 1995/07/06-07/09 as ParseArgs.pm
# renamed to Getopt::Tabular and somewhat reorganized/reworked,
# 1996/11/08-11/10
#
# $Id: Tabular.pm,v 1.8 1999/04/08 01:11:24 greg Exp $

# Copyright (c) 1995-98 Greg Ward. All rights reserved.  This package is
# free software; you can redistribute it and/or modify it under the same
# terms as Perl itself.

require Exporter;
use Carp;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use vars qw/%Patterns %OptionHandlers %TypeDescriptions @OptionPatterns
            %SpoofCode $OptionTerminator $HelpOption
            $LongHelp $Usage $ErrorClass $ErrorMessage/;

$VERSION = 0.3;
@ISA = qw/Exporter/;
@EXPORT = qw/GetOptions/;
@EXPORT_OK = qw/SetHelp SetHelpOption SetError GetError SpoofGetOptions/;

# -------------------------------------------------------------------- #
# Private global variables                                             #
# -------------------------------------------------------------------- #


# The regexp for floating point numbers here is a little more permissive
# than the C standard -- it recognizes "0", "0.", ".0", and "0.0" (where 0
# can be substituted by any string of one or more digits), preceded by an
# optional sign, and followed by an optional exponent.

%Patterns = ('integer' => '[+-]?\d+',
             'float'   => '[+-]? ( \d+(\.\d*)? | \.\d+ ) ([Ee][+-]?\d+)?',
             'string'  => '.*');


# This hash defines the allowable option types, and what to do when we
# see an argument of a given type in the argument list.  New types
# can be added by calling AddType, as long as you supply an option
# handler that acts like one of the existing handlers.  (Ie. takes
# the same three arguments, returns 1 for success and 0 for failure,
# and calls SetError appropriately.)

%OptionHandlers = ("string",    \&process_pattern_option,
                   "integer",   \&process_pattern_option,
                   "float",     \&process_pattern_option,
                   "boolean",   \&process_boolean_option,
                   "const",     \&process_constant_option,
                   "copy",      \&process_constant_option,
                   "arrayconst",\&process_constant_option,
                   "hashconst", \&process_constant_option,
                   "call",      \&process_call_option,
                   "eval",      \&process_eval_option,
                   "section",   undef);

# This hash is used for building error messages for pattern types.  A
# subtle point is that the description should be such that it can be
# pluralized by adding an "s".  OK, OK, you can supply an alternate
# plural form by making the description a reference to a two-element list,
# singular and plural forms.  I18N fanatics should be happy.

%TypeDescriptions = ("integer" => "integer",
                     "float"   => "floating-point number",
                     "string"  => "string");

@OptionPatterns = ('(-)(\w+)');        # two parts: "prefix" and "body"
$OptionTerminator = "--";
$HelpOption = "-help";

# The %SpoofCode hash is for storing alternate versions of callbacks
# for call or eval options.  The alternate versions should have no side
# effects apart from changing the argument list identically to their
# "real" alternatives.

%SpoofCode = ();

$ErrorClass = "";                       # can be "bad_option", "bad_value",
                                        # "bad_eval", or "help"
$ErrorMessage = "";                     # can be anything

# -------------------------------------------------------------------- #
# Public (but not exported) subroutines used to set options before     #
# calling GetOptions.                                                  #
# -------------------------------------------------------------------- #

sub SetHelp
{
   $LongHelp = shift;
   $Usage = shift;
}

sub SetOptionPatterns
{
   @OptionPatterns = @_;
}

sub SetHelpOption
{
   $HelpOption = shift;
}

sub SetTerminator
{
   $OptionTerminator = shift;
}

sub UnsetTerminator
{
   undef $OptionTerminator;
}

sub AddType
{
   my ($type, $handler) = @_;
   croak "AddType: \$handler must be a code ref"
      unless ref $handler eq 'CODE';
   $OptionHandlers{$type} = $handler;
}

sub AddPatternType
{
   my ($type, $pattern, $description) = @_;
   $OptionHandlers{$type} = \&process_pattern_option;
   $Patterns{$type} = $pattern;
   $TypeDescriptions{$type} = ($description || $type);
}

sub GetPattern
{
   my ($type) = @_;
   $Patterns{$type};
}

sub SetSpoofCodes
{
   my ($option, $code);
   croak "Even number of arguments required"
      unless (@_ > 0 && @_ % 2 == 0);

   while (@_)
   {
      ($option, $code) = (shift, shift);
      $SpoofCode{$option} = $code;
   }
}

sub SetError
{
   $ErrorClass = shift;
   $ErrorMessage = shift;
}

sub GetError
{
   ($ErrorClass, $ErrorMessage);
}

# --------------------------------------------------------------------
# Private utility subroutines:
#   quote_strings
#   print_help
#   scan_table
#   match_abbreviation
#   option_error
#   check_value
#   split_option
#   find_calling_package
# --------------------------------------------------------------------


#
# "e_strings
#
# prepares strings for printing in a list of default values (for the
# help text).  If a string is empty or contains whitespace, it is quoted;
# otherwise, it is left alone.  The input list of strings is returned
# concatenated into a single space-separated string.  This is *not*
# rigorous by any stretch; it's just to make the help text look nice.
#
sub quote_strings
{
   my @strings = @_;
   my $string;
   foreach $string (@strings)
   {
      $string = qq["$string"] if ($string eq '' || $string =~ /\s/);
   }
   return join (' ', @strings);
}


#
# &print_help
#
# walks through an argument table and prints out nicely-formatted
# option help for all entries that provide it.  Also does the Right Thing
# (trust me) if you supply "argument description" text after the help.
#
# Don't read this code if you can possibly avoid it.  It's pretty gross.
#
sub print_help
{
   confess ("internal error, wrong number of input args to &print_help")
      if (scalar (@_) != 1);
   my ($argtable) = @_;
   my ($maxoption, $maxargdesc, $numcols, $opt, $breakers);
   my ($textlength, $std_format, $alt_format);
   my ($option, $type, $num, $value, $help, $argdesc);

   $maxoption = 0;
   $maxargdesc = 0;

   # Loop over all options to determine the length of the longest option name
   foreach $opt (@$argtable)
   {
      my ($argdesclen, $neg_option);
      my ($option, $type, $help, $argdesc) = @{$opt} [0,1,4,5];
      next if $type eq "section" or ! defined $help;

      # Boolean options contribute *two* lines to the help: one for the
      # option, and one for its negative.  Other options just contribute
      # one line, so they're a bit simpler.
      if ($type eq 'boolean')
      {
         my ($pos, $neg) = &split_option ($opt);
         my $pos_len = length ($pos);
         my $neg_len = length ($neg);
         $maxoption = $pos_len if ($pos_len > $maxoption);
         $maxoption = $neg_len if ($pos_len > $maxoption);
         carp "Getopt::Tabular: argument descriptions ignored " .
              "for boolean option \"$option\""
            if defined $argdesc;
      }
      else
      {
         my $optlen = length ($option);
         $maxoption = $optlen if ($optlen > $maxoption);

         if (defined $argdesc)
         {
            $argdesclen = length ($argdesc);
            $maxargdesc = $argdesclen if ($argdesclen > $maxargdesc);
         }
      }
   }

   # We need to construct and eval code that looks something like this:
   #    format STANDARD =
   #    @<<<<<<<<<<<<<<<  ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
   # $option,        $help
   # ~~                   ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
   #                 $help
   # .
   #
   # with an alternative format like this:
   #    format ALTERNATIVE =
   #    @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
   # $option, $argdesc
   #                      ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
   #                 $help
   # ~~                   ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
   #                 $help
   # .
   # in order to nicely print out the help.  Can't hardcode a format,
   # though, because we don't know until now how much space to allocate
   # for the option (ie. $maxoption).

   local $: = " \n";
   local $~;

   $numcols = 80;                       # not always accurate, but faster!

   # width of text = width of terminal, with columns removed as follows:
   # 3 (for left margin), $maxoption (option names), 2 (gutter between
   # option names and help text), and 2 (right margin)
   $textlength = $numcols - 3 - $maxoption - 2 - 2;
   $std_format = "format STANDARD =\n" .
      "   @" . ("<" x $maxoption) . " ^" . ("<" x ($textlength-1)) . "\n".
      "\$option, \$help\n" .
      "~~  " . (" " x $maxoption) . " ^" . ("<" x ($textlength-1)) . "\n" .
      "\$help\n.";
   $alt_format = "format ALTERNATIVE =\n" .
      "   @" . ("<" x ($maxoption + $maxargdesc)) . "\n" .
      "\$option\n" .
      "   " . (" " x $maxoption) . "  ^" . ("<" x ($textlength-1)) . "\n" .
      "\$help\n" .
      "~~ " . (" " x $maxoption) . "  ^" . ("<" x ($textlength-1)) . "\n" .
      "\$help\n.";

   eval $std_format;
   confess ("internal error with format \"$std_format\": $@") if $@;
   eval $alt_format;
   confess ("internal error with format \"$alt_format\": $@") if $@;

   my $show_defaults = 1;

   print $LongHelp . "\n" if defined $LongHelp;
   print "Summary of options:\n";
   foreach $opt (@$argtable)
   {
      ($option, $type, $num, $value, $help, $argdesc) = @$opt;

      if ($type eq "section")
      {
	 printf "\n-- %s %s\n", $option, "-" x ($numcols-4-length($option));
         next;
      }

      next unless defined $help;
      $argdesc = "" unless defined $argdesc;

      my $show_default = $show_defaults && $help !~ /\[default/;

      $~ = 'STANDARD';
      if ($type eq 'boolean')
      {
         undef $option;                 # arg! why is this necessary?
         my ($pos, $neg) = &split_option ($opt);
         $option = $pos;
         $help .= ' [default]'
            if $show_default && defined $$value && $$value;
         write;
         $help = "opposite of $pos";
         $help .= ' [default]'
            if $show_default && defined $$value && ! $$value;
         $option = $neg;
         write;
      }
      else
      {
         # If the option type is of the argument-taking variety, then
         # we'll try to help out by saying what the default value(s)
         # is/are
         if ($OptionHandlers{$type} == \&process_pattern_option)
         {
            if ($num == 1)              # expectes a scalar value
            {
               $help .= ' [default: ' . quote_strings ($$value) . ']'
                  if ($show_default && defined $$value);
            }
            else                        # expects a vector value
            {
               $help .= ' [default: ' . quote_strings (@$value) . ']'
                  if ($show_default &&
                      @$value && ! grep (! defined $_, @$value));
            }
         }

         if ($argdesc)
         {
            my $expanded_option = $option . " " . $argdesc if $argdesc;
            $option = $expanded_option;

            if (length ($expanded_option) > $maxoption+1)
            {
               $~ = 'ALTERNATIVE';
            }
         }
         write;
      }
   }

   print "\n";
   print $Usage if defined $Usage;
}


#
# &scan_table
#
# walks through an argument table, building a hash that lets us quickly
# and painlessly look up an option.
#
sub scan_table
{
   my ($argtable, $arghash) = @_;
   my ($opt, $option, $type, $value);

   my $i;
   for $i (0 .. $#$argtable)
   {
      $opt = $argtable->[$i];
      ($option, $type, $value) = @$opt;
      unless (exists $OptionHandlers{$type})
      {
	 croak "Unknown option type \"$type\" supplied for option $option";
      }

      if ($type eq "boolean")
      {
         my ($pos,$neg) = &split_option($opt);
	 $arghash->{$pos} = $i;
         $arghash->{$neg} = $i if defined $neg;
      }
      elsif ($type ne "section")
      {
	 $arghash->{$option} = $i;
      }
   }
}


#
# &match_abbreviation
#
# Given a string $s and a list of words @$words, finds the word for which
# $s is a non-ambiguous abbreviation.  If $s is found to be ambiguous or
# doesn't match, a clear and concise error message is printed, using
# $err_format as a format for sprintf.  Suggested form for $err_format is
# "%s option: %s"; the first %s will be substituted with either "ambiguous"
# or "unknown" (depending on the problem), and the second will be
# substituted with $s.  Thus, with this format, the error message will look
# something like "unknown option: -foo" or "ambiguous option: -f".
#
sub match_abbreviation
{
   my ($s, $words, $err_format) = @_;
   my ($match);

   my $word;
   foreach $word (@$words)
   {
      # If $s is a prefix of $word, it's at least an approximate match,
      # so try to do better

      next unless ($s eq substr ($word, 0, length ($s)));

      # We have an exact match, so return it now

      return $word if ($s eq $word);

      # We have an approx. match, and already had one before

      if ($match)
      {
         &SetError ("bad_option", sprintf ("$err_format", "ambiguous", $s));
	 return 0;
      }

      $match = $word;
   }
   &SetError ("bad_option", sprintf ("$err_format", "unknown", $s))
      if !$match;
   $match;
}


#
# &option_error
#
# Constructs a useful error message to deal with an option that expects
# a certain number of values of certain types, but a command-line that
# falls short of this mark.  $option should be the option that triggers
# the situation; $type should be the expected type; $n should be the
# number of values expected.
#
# The error message (returned by the function) will look something like
# "-foo option must be followed by an integer" (yes, it does pick "a"
# or "an", depending on whether the description of the type starts
# with a vowel) or "-bar option must be followed by 3 strings".
#
# The error message is put in the global $ErrorMessage, as well as returned
# by the function.  Also, the global $ErrorClass is set to "bad_value".
#
sub option_error
{
   my ($option, $type, $n) = @_;
   my ($typedesc, $singular, $plural, $article, $desc);

   $typedesc = $TypeDescriptions{$type};
   ($singular,$plural) = (ref $typedesc eq 'ARRAY')
      ? @$typedesc
      : ($typedesc, $typedesc . "s");

   $article = ($typedesc =~ /^[aeiou]/) ? "an" : "a";
   $desc = ($n > 1) ?
      "$n $plural" :
      "$article $singular";
   &SetError ("bad_value", "$option option must be followed by $desc");
}


#
# &check_value
#
# Verifies that a value (presumably from the command line) satisfies
# the requirements for the expected type.
#
# Calls &option_error (to set $ErrorClass and $ErrorMessage globals) and returns
# 0 if the value isn't up to scratch.
#
sub check_value
{
   my ($val, $option, $type, $n) = @_;

   unless (defined $val && $val =~ /^$Patterns{$type}$/x)
   {
      &option_error ($option, $type, $n);
      return 0;
   }
}


#
# &split_option
#
# Splits a boolean option into positive and negative alternatives.  The
# two alternatives are returned as a two-element array.
#
# Croaks if it can't figure out the alternatives, or if there appear to be
# more than 2 alternatives specified.
#
sub split_option
{
   my ($opt_desc) = @_;
   my ($option, @options);

   $option = $opt_desc->[0];
   return ($option) if $opt_desc->[1] ne "boolean";

   @options = split ('\|', $option);

   if (@options == 2)
   {
      return @options;
   }
   elsif (@options == 1)
   {
      my ($pattern, $prefix, $positive_alt, $negative_alt);
      for $pattern (@OptionPatterns)
      {
         my ($prefix, $body);
         if (($prefix, $body) = $option =~ /^$pattern$/)
         {
            $negative_alt = $prefix . "no" . $body;
            return ($option, $negative_alt);
         }
      }
      croak "Boolean option \"$option\" did not match " .
         "any option prefixes - unable to guess negative alternative";
      return ($option);
   }
   else
   {
      croak "Too many alternatives supplied for boolean option \"$option\"";
   }
}


#
# &find_calling_package
#
# walks up the call stack until we find a caller in a different package
# from the current one.  (Handy for `eval' options, when we want to
# eval a chunk of code in the package that called GetOptions.)
#
sub find_calling_package
{
   my ($i, $this_pkg, $up_pkg, @caller);

   $i = 0;
   $this_pkg = (caller(0))[0];
   while (@caller = caller($i++))
   {
      $up_pkg = $caller[0];
      last if $up_pkg ne $this_pkg;
   }
   $up_pkg;
}


# ----------------------------------------------------------------------
# Option-handling routines:
#   process_constant_option
#   process_boolean_option
#   process_call_option
#   process_eval_option
# ----------------------------------------------------------------------

# General description of these routines:
#   * each one is passed exactly four options:
#       $arg      - the argument that triggered this routine, expanded
#                   into unabbreviated form
#       $arglist  - reference to list containing rest of command line
#       $opt_desc - reference to an option descriptor list
#       $spoof    - flag: if true, then no side effects
#   * they are called from GetOptions, through code references in the
#     %OptionHandlers hash
#   * if they return a false value, then GetOptions immediately returns
#     0 to its caller, with no error message -- thus, the option handlers
#     should print out enough of an error message for the end user to
#     figure out what went wrong; also, the option handlers should be
#     careful to explicitly return 1 if everything went well!

sub process_constant_option
{
   my ($arg, $arglist, $opt_desc, $spoof) = @_;
   my ($type, $n, $value) = @$opt_desc[1,2,3];

   return 1 if $spoof;

   if ($type eq "const")
   {
      $$value = $n;
   }
   elsif ($type eq "copy")
   {
      $$value = (defined $n) ? ($n) : ($arg);
   }
   elsif ($type eq "arrayconst")
   {
      @$value = @$n;
   }
   elsif ($type eq "hashconst")
   {
      %$value = %$n;
   }
   else
   {
      confess ("internal error: can't handle option type \"$type\"");
   }

   1;
}


sub process_boolean_option
{
   my ($arg, $arglist, $opt_desc, $spoof) = @_;
   my ($value) = $$opt_desc[3];

   return 1 if $spoof;

   my ($pos,$neg) = &split_option ($opt_desc);
   confess ("internal error: option $arg not found in argument hash")
      if ($arg ne $pos && $arg ne $neg);

   $$value = ($arg eq $pos) ? 1 : 0;
   1;
}


sub process_call_option
{
   my ($arg, $arglist, $opt_desc, $spoof) = @_;
   my ($option, $args, $value) = @$opt_desc[0,2,3];

   croak "Invalid option table entry for option \"$option\" -- \"value\" " .
         "field must be a code reference"
      unless (ref $value eq 'CODE');

   # This will crash 'n burn big time if there is no spoof code for
   # this option -- but that's why we check %SpoofCode against the
   # arg table from GetOptions!

   $value = $SpoofCode{$arg} if ($spoof);

   my @args = (ref $args eq 'ARRAY') ? (@$args) : ();
   my $result = &$value ($arg, $arglist, @args);
   if (!$result)
   {
      # Wouldn't it be neat if we could get the sub name from the code ref?
      &SetError
         ($ErrorClass || "bad_call",
          $ErrorMessage || "subroutine call from option \"$arg\" failed");
   }

   return $result;

}  # &process_call_option


sub process_eval_option
{
   my ($arg, $arglist, $opt_desc, $spoof) = @_;
   my ($value) = $$opt_desc[3];

   $value = $SpoofCode{$arg} if ($spoof);

   my $up_pkg = &find_calling_package ();
#   print "package $up_pkg; $value";  # DEBUG ONLY
   my $result = eval "package $up_pkg; no strict; $value";

   if ($@)		# any error string set?
   {
      &SetError ("bad_eval",
                 "error evaluating \"$value\" (from $arg option): $@");
      return 0;
   }

   if (!$result)
   {
      &SetError
         ($ErrorClass || "bad_call",
          $ErrorMessage || "code eval'd for option \"$arg\" failed");
   }

   return $result;
}


sub process_pattern_option
{
   my ($arg, $arglist, $opt_desc, $spoof) = @_;
   my ($type, $n, $value) = @$opt_desc[1,2,3];
   my ($dummy, @dummies);

   # This code looks a little more complicated than you might at first
   # think necessary.  But the ugliness is necessary because $value might
   # reference a scalar or an array, depending on whether $n is 1 (scalar)
   # or not (array).  Thus, we can't just assume that either @$value or
   # $$value is valid -- we always have to check which of the two it should
   # be.

   if ($n == 1)                         # scalar-valued option (one argument)
   {
      croak "GetOptions: \"$arg\" option must be associated with a scalar ref"
         unless ref $value eq 'SCALAR';
      $value = \$dummy if $spoof;
      $$value = shift @$arglist;
      return 0 unless &check_value ($$value, $arg, $type, $n);
   }
   else                                 # it's a "vector-valued" option
   {                                    # (fixed number of arguments)
      croak "GetOptions: \"$arg\" option must be associated with an array ref"
         unless ref $value eq 'ARRAY';
      $value = \@dummies if $spoof;
      @$value = splice (@$arglist, 0, $n);
      if (scalar @$value != $n)
      {
         &option_error ($arg, $type, $n);
         return 0;
      }

      my $val;
      foreach $val (@$value)
      {
         return 0 unless &check_value ($val, $arg, $type, $n);
      }
   }  # else

   return 1;

}  # &process_pattern_option


# --------------------------------------------------------------------
# The main public subroutine: GetOptions
# --------------------------------------------------------------------

sub GetOptions
{
   my ($opt_table, $arglist, $new_arglist, $spoof) = @_;
   my (%argpos, $arg, $pos, $opt_ref);
   my ($option_re, @option_list);

   $new_arglist = $arglist if !defined $new_arglist;
   &SetError ("", "");

   # Build a hash mapping option -> position in option table

   &scan_table ($opt_table, \%argpos);

   # Regexp to let us recognize options on the command line

   $option_re = join ("|", @OptionPatterns);

   # Build a list of all acceptable options -- used to match abbreviations

   my $opt_desc;
   foreach $opt_desc (@$opt_table)
   {
      push (@option_list, &split_option ($opt_desc))
	 unless $opt_desc->[1] eq "section";
   }
   push (@option_list, $HelpOption) if $HelpOption;

   # If in spoof mode: make sure we have spoof code for all call/eval options

   if ($spoof)
   {
      my ($opt, $type, $spoof);

      foreach $opt_desc (@$opt_table)
      {
         $opt = $opt_desc->[0];
         $type = $opt_desc->[1];
         $spoof = $SpoofCode{$opt};

         next unless $type eq 'call' || $type eq 'eval';
         croak "No alternate code supplied for option $opt in spoof mode"
            unless defined $spoof;
         croak "Alternate code must be a CODE ref for option $opt"
            if ($type eq 'call' && ref $spoof ne 'CODE');
         croak "Alternate code must be a string for option $opt"
            if ($type eq 'eval' && ref $spoof);
      }
   }

   # Now walk over the argument list

   my @tmp_arglist = @$arglist;
   @$new_arglist = ();
   while (defined ($arg = shift @tmp_arglist))
   {
#     print "arg: $arg\n";

      # If this argument is the option terminator (usually "--") then
      # transfer all remaining arguments to the new arg list and stop
      # processing immediately.

      if (defined $OptionTerminator && $arg eq $OptionTerminator)
      {
         push (@$new_arglist, @tmp_arglist);
         last;
      }

      # If this argument isn't an option at all, just append it to
      # @$new_arglist and go to the next one.

      if ($arg !~ /^($option_re)/o)
      {
         push (@$new_arglist, $arg);
         next;
      }

      # We know we have something that looks like an option; see if it
      # matches or is an abbreviation for one of the strings in
      # @option_list

      $arg = &match_abbreviation ($arg, \@option_list, "%s option: %s");
      if (! $arg)
      {
         warn $Usage if defined $Usage;
         warn "$ErrorMessage\n";
         return 0;
      }

      # If it's the help option, print out the help and return
      # (even if in spoof mode!)

      if ($arg eq $HelpOption)
      {
         &print_help ($opt_table);
         &SetError ("help", "");
         return 0;
      }

      # Now we know it's a valid option, and it's not the help option --
      # so it must be in the caller's option table.  Look up its
      # entry there, and use that for the actual option processing.

      $pos = $argpos{$arg};
      confess ("internal error: didn't find arg in arg hash even " .
               "after resolving abbreviation")
         unless defined $pos;

      my $opt_desc = $opt_table->[$pos];
      my $type = $opt_desc->[1];
      my $handler = $OptionHandlers{$type};

      if (defined $handler && ref ($handler) eq 'CODE')
      {
         if (! &$handler ($arg, \@tmp_arglist, $opt_desc, $spoof))
         {
            warn $Usage if defined $Usage;
            warn "$ErrorMessage\n";
            return 0;
         }
      }
      else
      {
         croak "Unknown option type \"$type\" (found for arg $arg)";
      }
   }     # while ($arg = shift @$arglist)

   return 1;

}     # GetOptions


sub SpoofGetOptions
{
   &GetOptions (@_[0..2], 1);
}

1;