package ParseArgs;

# ParseArgs.pm
#
# Perl5 package 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 &ParseArgs (the name
# is exported from the module).  &ParseArgs takes two arguments:
# a reference to your argument table (which is not modified), and
# a reference to the list of command line arguments, e.g. @ARGV (or
# a copy of it), which is modified considerably.
#
# 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 ParseArgs.pod for complete information.
# 
# by Greg Ward 95/07/06 - 95/07/09

# $Id: ParseArgs.pm,v 1.24 1997/09/02 14:07:49 greg Exp $

# --------------------------------------------------------------------
# Copyright (c) 1995-96 Greg Ward, McConnell Brain Imaging Centre,
# Montreal Neurological Institute, McGill University.  Permission to
# use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted,
# provided that the above copyright notice appear in all copies.  The
# author and McGill University make no representations about the
# suitability of this software for any purpose.  It is provided "as
# is" without express or implied warranty.
# --------------------------------------------------------------------

require Exporter;
use Carp;

use strict;
use vars qw(@ISA @EXPORT);
use vars qw/%Patterns %OptionHandlers %TypeDescriptions @OptionPatterns
            $OptionTerminator $AllowTermination $HelpOption
            $LongHelp $Usage/;

@ISA = qw/Exporter/;
@EXPORT = qw/ParseArgs/;

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

# regexp for C floating point numbers adapted from the grammar for
# ANSI C that comes with pccts 1.1 (ack. to Terence Parr)

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

%OptionHandlers = ("string",    \&process_pattern_option, 
                   "integer",   \&process_pattern_option, 
                   "float",     \&process_pattern_option, 
                   "boolean",   \&process_boolean_option, 
                   "constant",  \&process_constant_option, 
                   "copy",      \&process_constant_option, 
                   "copyarray", \&process_constant_option, # obsolete!
                   "arrayconst",\&process_constant_option, 
                   "copyhash",  \&process_constant_option, # obsolete!
                   "hashconst", \&process_constant_option, 
                   "call",      \&process_call_option, 
                   "eval",      \&process_eval_option, 
                   "section",   undef);


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

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

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

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

sub SetOptionPatterns
{
   @OptionPatterns = @_;
}

sub SetHelpOption
{
   $HelpOption = shift;
}

sub SetTerminator
{
   $OptionTerminator = shift;
   $AllowTermination = 1;
}

sub UnsetTerminator
{
   $AllowTermination = 0;
}

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

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

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

#
# &printhelp
#
# 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 printhelp
{
   confess ("internal error, wrong number of input args to &printhelp")
      if (scalar (@_) != 1);
   my ($argtable) = @_;
   my ($maxoption, $maxargdesc, $numcols, $opt, $breakers);
   my ($textlength, $std_format, $alt_format);
   my ($option, $type, $help, $argdesc);

   $maxoption = 0;
   $maxargdesc = 0;

   foreach $opt (@$argtable)
   {
      my ($optlen, $argdesclen);
      my ($option, $type, $help, $argdesc) = @{$opt} [0,1,4,5];
      next if $type eq "section" or ! defined $help;

      ($option) = &split_option ($opt) if $type eq "boolean";
      $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).

   $breakers = $:;
   $: = " \n";
   chop ($numcols = `tput cols`);       # should use Term::Cap here, I s'pose
   $numcols = 80 if $? || !$numcols;

   $textlength = $numcols - 3 - $maxoption - 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 $save_fmt = $~;

   print $LongHelp . "\n" if defined $LongHelp;
   print "Summary of options:\n";
   foreach $opt (@$argtable)
   {
      ($option, $type, $help, $argdesc) = @{$opt}[0,1,4,5];

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

      next unless defined $help;
      $argdesc = "" unless defined $argdesc;
      ($option) = &split_option ($opt) if $type eq "boolean";

      $~ = 'STANDARD';
      if ($argdesc)
      {
         my $expanded_option = $option . " " . $argdesc if $argdesc;
         $option = $expanded_option;
         
         if (length ($expanded_option) > $maxoption+1)
         {
            $~ = 'ALTERNATIVE';
         }
      }         
      write;
   }
   $: = $breakers;
   $~ = $save_fmt;
   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.  This isn't really needed anymore, 
# now that I have &match_abbreviation.  Oh well.
#
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 "ParseArgs: error, unknown type ($type) supplied " .
               "for option $option";
      }

      carp "ParseArgs: warning, obsolete option type ($type) supplied " .
           "for option $option"
         if ($type eq "copyarray" || $type eq "copyhash");

      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;
      }
   }
   return 1;
}


#
# &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)
      {				
	 warn sprintf ("$err_format\n", "ambiguous", $s);
	 return 0;
      }

      $match = $word;
   }
   warn sprintf ("$err_format\n", "unknown", $s) unless $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".
#
sub option_error
{   
   my ($option, $type, $n) = @_;
   my ($typedesc, $article, $desc);

   $typedesc = $TypeDescriptions{$type};
   $article = ($typedesc =~ /^[aeiou]/) ? "an" : "a";
   $desc = ($n > 1) ? 
      "$n ${typedesc}s" : 
      "$article $typedesc";
   "$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.
#
# Prints an error message (supplied by &option_error) if the value
# isn't up to scratch.
#
sub check_value
{
   my ($val, $option, $type, $n) = @_;

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


# 
# &split_option
#
# Splits a boolean option into positive and negative alternatives.  The 
# two alternatives are returned as a two-element array.
# 
# If it can't figure out the negative alternative, prints a warning and
# returns just the positive alternative.
#
# Croaks if there appear to be > 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);
         }
      }
      carp "ParseArgs: warning, boolean option \"$option\" did not match " .
         "any option prefixes - unable to guess negative alternative";
      return ($option);
   }
   else
   {
      croak "ParseArgs: error, too many alternatives supplied for boolean option $option";
   }
}


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-processing routines:
#   process_constant_option
#   process_boolean_option
#   process_call_option
#   process_eval_option
#   process_option
# ----------------------------------------------------------------------

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

   if ($type eq "constant")
   {
      $$value = $n;
   }
   elsif ($type eq "copy")
   {
      $$value = (defined $n) ? ($n) : ($arg);
   }
   elsif ($type eq "arrayconst" || $type eq "copyarray")
   {
      @$value = @$n;
   }
   elsif ($type eq "hashconst" || $type eq "copyhash")
   {
      %$value = %$n;
   }

   1;
}


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

   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) = @_;
   my ($args, $value) = @$opt_desc[2,3];

   if (ref $value eq 'CODE')
   {
      my @args = (ref $args eq 'ARRAY') ? (@$args) : ();
      return (&$value ($arg, $arglist, @args));
   }
   else
   {
      my ($up_pkg, $evalstr, $result);
      
      carp "ParseArgs: warning, using obsolete form of `call' type";
      
      $up_pkg = &find_calling_package ();
      $evalstr = <<END;
package $up_pkg;
&${value} (\$ParseArgs::arg, \$ParseArgs::arglist);
END
#     print $evalstr;                # DEBUG ONLY
      $result = eval $evalstr;
   
      if ($@)
      {
         carp "ParseArgs: error calling $value: $@";
         return 0;
      }
      return $result;
   }  # else: old-style call (through eval)
}  # &process_call_option


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

   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?
   {
      carp "ParseArgs: error evaluating \"$value\": $@\n";
      return 0;
   }

   return $result;
}


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

   # 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)
   {                                    
      $$value = shift @$arglist;
      return 0 unless &check_value ($$value, $arg, $type, $n);
   }
   else                                 # it's a "vector-valued" option
   {                                    # (fixed number of arguments)
      @$value = splice (@$arglist, 0, $n);
      if (scalar @$value != $n)
      {
         warn &option_error ($arg, $type, $n) . "\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: ParseArgs                                #
# -------------------------------------------------------------------- #

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

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

   &scan_table ($opt_table, \%argpos) || return 0;

   # 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;


   # Now walk over the argument list

   while (defined ($arg = shift @$arglist))
   {
#     print "arg: $arg\n";
      last if ($AllowTermination && $arg eq $OptionTerminator);
      if ($arg !~ /^($option_re)/o)
      {
         push (@new_arglist, $arg);
         next;
      }

      $arg = &match_abbreviation ($arg, \@option_list, "%s option: %s");
      if (! $arg)
      {
         @$arglist = @new_arglist;
         return 0;
      }

      if ($arg eq $HelpOption)
      {
         &printhelp ($opt_table);
         return 0;
      }

      $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];

      if (exists $OptionHandlers{$type} && 
          ref ($OptionHandlers{$type}) eq 'CODE')
      {
         &{$OptionHandlers{$type}} ($arg, $arglist, $opt_desc)
            || return 0;
      }
      else
      {
         croak "Unknown option type $type (found for arg $arg)";
      }
   }     # while ($arg = shift @$arglist)


   # We unshift (prepend) onto @$arglist in case we found an 
   # OptionTerminator ("--", usually) on the command line -- in
   # that case, there's probably still useful stuff left in @$arglist
   # that we need to preserve.

   unshift (@$arglist, @new_arglist);
   return 1;

}     # ParseArgs


sub Parse { &ParseArgs; }               # alias for backward compatibility

1;
