# -*- perl -*-
# Options.pm $Id: Options.pm,v 1.3 1999/01/30 15:42:29 jens Exp $
# (C) Copyright 1998-1999 Jens G Jensen <jens@arcade.mathematik.uni-freiburg.de>

# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
# Or see http://www.gnu.org/copyleft/gpl.html




=pod

=head1 Documentation for Options.pm version $Id: Options.pm,v 1.3 1999/01/30 15:42:29 jens Exp $

=head2 What is Options.pm?

Options.pm is a package (actually a class (to be precise, a singleton class)) designed
to handle options for the epsmerge program.  However, there is nothing that binds Options.pm
to epsmerge; it may be used independently.

Options.pm has some advantages over Getopt::Long and friends.  It allows checking and
reformatting option values (through routines supplied by the programmer), it allows
default values to be specified by the programmer, or set by the user in a configuration
file.

=head2 Initializing Options

The first thing your program should do should be to call
    Options->new( vlist, \@ARGV, fname )
where vlist is a option/value list (see below) describing your options, their
default values, how to check them, etc, C<\@ARGV> is a reference to the array
(ususally C<@ARGV>) that you want to parse for options, and fname is the name
of the configuration file that the user (or the programmer) may want to supply.

=head2 The option/value list

The option/value list should be a list of array refs, each consisting of:

=over

=item 1

Short option name (e.g., '-o'), can be undef if not available.
It is highly recommended that short options start with a I<single> '-'
but they don't have to be just one letter (i.e., '-foo' is fine).
However, bundling short options as when calling perl is not supported
(i.e., '-baz' is not the same as '-b -a -z').  Also, short options are
always I<case sensitive>.

=item 2

Long option name (e.g., '--output-file'); can be undef.  It is
highly recommended that long options start with '--'.  When the
long options are parsed, they are I<case insensitive>.

=item 3

Value identifier a la Getopt::Long:

'=s' : mandatory string

':s' : optional string

Similarly with letters 'b' (boolean), 'i' (integer).  "" means no value.

=item 4

Optional subroutine ref, that can transform the value (e.g., length
specified in inches can be converted to cm).  This routine can also perform
sanity checks and should return undef if it doesn't like the value
that was passed to it.

=item 5

Default value.  Don't make this undef.  This is the value that will be
associated with the option if the user does not type the option on the
command line I<and> has not associated a value to this option in the
configuration file.  Note that options classified (in (3) above) as
having optional parameters get a different value (based on the type of
the variable) if the user types the option on the command line but does
not supply a value.  This only applies to options with optional values;
if the value is mandatory then this supplied default value is ignored.
Also, it is I<not> tested with the subroutine from (4) (if available),
since it is assumed that you know what you are doing with this value.

=item 6

Optional help string that describes how to use this option.  Not sure that this
is an ace idea, but let's keep it here for now, OK?

=back

=head2 The checking subroutine

The subroutine will be called with the following parameters:

=over

=item 1

The value corresponding to the option (usually this is the one you'd want to check.)

=item 2

A reference to the command line arguments, I<including> the argument that you are
supposed to check (i.e., it is first in the list).  Don't mess with
those unless you know what you are doing (i.e., option needs to gobble more arguments).
Currently, Options.pm will shift the 0th value off anyway, so if you gobble
arguments, leave one extra to be shifted.

=item 3

The option tag (see below) (in case several options are checked by the same routine.)

=back

Normally, your routine should just worry about the first value and leave the other
two alone.

The subroutine should I<return> the desired value (unchanged or updated or
translated or transmogrified or what-have-you) as a I<scalar>, I<or> return undefined if
the value is not recognized.  The subroutine should I<not> print
anything (error messages, or suchlike).

=head2 What is that "tag" you mention?

The tag is a string identifying the option to Options.pm itself and to the program
that uses Options.pm.  Suppose an option has long name '--gnusto-rezrov' and short
name '-gr'.  Then the tag will be the short name with the leading '-' stripped off,
i.e. 'gr'.  If there was no short name, then the tag will be the long name with the
leading '--' stripped of, in this case 'gnusto-rezrov'.  The short name will always
be preferred to generate a tag if it is available.  It is an error if there is
neither a short name nor a long name for a given option.

=head2 How to read option values

=over

=item 1

Create an instance of the Options class.

    my $opt = Options->new();

Since this is not the first time you call options (see section L<Initializing Options>),
you don't need to pass any parameters.  Moreover, you can create as many instances of
Options as you like; since the class is a singleton you will always get the same class,
and Perl will recycle them at some point after they go out of scope.

=item 2

Call the getopts method with a list of tags, and it returns the corresponding list of values
Example: if C<$opt> contains your reference from step 1,

	$opt->getopts('baz')

will get the value of the option with short name '-baz' (or, if there
was no such option, the value of the long option '--baz').  Or

	$Options->new()->getopts('foo', 'bar')

will return a list containing two items, the value of the options with
tags 'foo' and 'bar', respectively.

It is an error if you call C<getopts('quincunx')> and 'quincunx' was never specified
in the option/value list when you initialized Options.

=back

=head2 How to override user's values (or define new options on the fly):

=over

=item 1

Create an instance of the Options class.

=item 2

Call the setopts method with a list of tag => newvalue (i.e., a hash).

    Options->new()->setopts( foo => 4, bar => 'ping' );

=back

These values are not checked since the programmer is supposed to know what
(s)he is doing.

=head2 The configuration file

The configuration file consists of lines where each individual line may be either

=over

=item

a comment: starts with '#' and continues to the end of the line (backslash continuation
not allowed),

=item

blank,

=item

or a line consisting of either

	name=value

or

	name: value

There may be whitespaces before and after the '=' or ':'.  The name in
this case is the short or long option name with the leading '-' or '--'
stripped away (this could be, but is not necessarily, the same as the
"tag").  This method was chosen to be easier for the user to remember.
The value is checked just as a command line option would be checked.

Options looks for the configuration file in all Perl's include directories
(obtained from @INC), and, if available, in the user's home directory.

=head2 Example

Suppose your program initializes Options as follows:

	$opt1 = [ '-h', '--help', ':b', undef, 0, "Get help for my program" ];
	$opt2 = [ '-o', undef, '=s', \&check_filename, "stdout", "The name of the output file" ];
	$opt3 = [ undef, '--foo', ':i', \&check_number, -1, "foo-value" ];

	Options->new( [ $opt1, $opt2, $opt3, ], \@ARGV, ".foorc" );

This makes Options recognise and parse three options (assuming you have defined
somewhere the hypothetical subroutines C<check_filename> and C<check_code>.)

Suppose further that the configuration file (".foorc") looks like this:

	# my configuration file
	o = beep.txt

and that the user calls your program (say it is called C<foo>) with the following
arguments:

	foo --foo 3 snap crackle pop

After the first call to Options->new(...), the Options class will now know the following
options and values:

	h => 0
	o => beep.txt
	foo => 3

so that if you call

	Options->new()->getopts('o', 'foo')

you will get a list of "beep.txt" and 3.  Moreover, the remaining three string values,

	snap crackle pop

will still remain in @ARGV (because they aren't be parsed as options).

=cut

# ' <= emacs fontify happiness



package Options;

use strict;

use vars qw($Self);
use Carp;

$Self = 0;


sub new {
    my $class = shift;
    return $Self if ref $Self;
    $Self = _parse( @_ );
    bless $Self, $class;
    return $Self;
}

sub getopts {
    shift;
    if( wantarray ) {
	my @values = ();
	foreach (@_) {
	    my $val = $Self->{$_};
	    croak "Fatal error: Option '$_' not specified" unless defined $val;
	    push @values, $val;
	}
	return @values;
    }
    my $val = $Self->{ $_[0] };
    croak "Fatal error: option '$_[0]' not specified" unless defined $val;
    return $val;
}

# Program can "by hand" opdate or set new options to some value
sub setopts {
    shift;
    my %newstuff = @_;
    my ($k, $v);
    while( ($k, $v) = each( %newstuff ) ) {
	$Self->{ $k } = $v;
    }
}

# summarize() prints to STDOUT a summary of all the options
# sub summarize {
# }

# _find_rc_file() tries to find the resource file; first by looking in @INC
# (should include the epsmerge .pm directories) and finally in the user's home directory.
# Um -- assumes that your path separation character is the right one ('/').
sub _find_rc_file {
    my $rcfilename = shift;
    return $rcfilename if( -e $rcfilename );
    my $path;
    foreach $path ( @INC ) {
	if( -e "$path/$rcfilename" ) {
	    return "$path/$rcfilename";
	}
    }
    if( -e "$ENV{HOME}/$rcfilename" ) {
	return "$ENV{HOME}/$rcfilename";
    }
    # print STDERR "Warning: Couldn't find resource file\n";
    return undef;
}

# Do essentially what _parse() does, except with the resource file.
# Gimme: reference to optioninfo array and the name of the resource file.
# I deliver: a hashref of { tag => value }
sub _parse_rc_file {
    my ($optref, $rcfilename) = @_;
    $rcfilename = _find_rc_file( $rcfilename );
    return { } unless defined $rcfilename;
    open(RCFILE, "<$rcfilename") or die "Couldn't open $rcfilename for reading\n";
    # %lookup serves as a name => data lookup as in _parse, but the names are different
    my %lookup = ( );
    foreach ( @$optref ) {
	my $name = $$_[0];	# short name
	if( $name ) {
	    $name =~ s/^-//;
	    $lookup{ $name } = $_;
	}
	$name = $$_[1];		# long name
	if( $name ) {
	    $name =~ s/^--//;
	    $lookup{ $name } = $_;
	}
    }
    my %hash = ( );
    while( <RCFILE> ) {
	next if /^\s*$/ || /^\#/; # blank line or comment
	unless( /(\w+)\s*[=:]\s*(\S.*)$/ ) {
	    chop;
	    print STDERR "Warning: I don't understand `", $_, "' in resource file, ignoring\n";
	    next;
	}
	my $name = $1;
	my $val = $2;
	my @args = split /\s+/, $val;
	my $rec = $lookup{ $name };
	unless( $rec ) {
	    print STDERR "Warning: unknown option `$name' in resource file, ignoring\n";
	    next;
	}
	if( defined $$rec[3] ) {
	    # Note the distinction: $val is one arg, possibly a collection of arguments,
	    # whereas @args is the same split as a list.
	    $val = &{$$rec[3]}( $val, \@args, $$rec[-1] );
	    unless( defined $val ) {
		print STDERR "Warning: weird value for `$name' in resource file, ignoring\n";
		next;
	    }
	}
	$hash{ $$rec[-1] } = $val;
    }
    close RCFILE;
    return \%hash;
}

sub _parse {
    my ($optref, $argvref, $rcfilename) = @_;
    # lookup is a hash of option_name => ref_to_array
    # both for the long and the short option names
    my %lookup = ( );
    my $self = { };
    foreach ( @$optref ) {
	my $tag = $$_[0] || $$_[1];
	die "Options must have a tag" unless $tag;
	$tag =~ s/^--?//;
	push @$_, $tag;		# put tag at *end* of option record array
	$lookup{ $$_[0] } = $_ if $$_[0]; # short name
	$lookup{ $$_[1] } = $_ if $$_[1]; # long name
    }
    while( @$argvref && $$argvref[0] =~ /^-/ ) {
	my $opt = shift @$argvref;
	last if $opt eq '--';
	$opt = lc( $opt ) if $opt =~ /^--/;
	# $rec is the record describing the option
	my $rec = $lookup{ $opt };
	unless( $rec ) {
	    print STDERR "Error: can't recognize option $opt\n";
	    exit(5);
	}
	my $val;
	if( $$rec[2] =~ /^:/ ) {
	    # optional parameter; code not winning beauty contests
	  OPTIONAL:
	    {			# begin bare block
		# An optional value should not be an option name, but
		# *may* be a negative number!
		if( @$argvref && $argvref->[0] =~ /^([^-]|-\d|-\.\d)/ ) {
		    # a value; not the next option
		    $val = $argvref->[0];
		    # first, internal check; integer
		    if( $$rec[2] eq ":i" ) {
			goto DEFAULT unless $val =~ /^-?\d+$/;
		    }
		    # does check routine accept this value?
		    if( $$rec[3] ) {
			# pass to routine: value, tag
			my $tval = &{$$rec[3]}( $val, $argvref, $$rec[-1] );
			if( defined $tval ) {
			    $val = $tval;
			    shift @$argvref;
			    last OPTIONAL;
			}
		    }
		    else {	# ! $$rec[3]
			shift @$argvref;
			last OPTIONAL;
		    }
		}
	      DEFAULT:
		# choose reasonable default (not necessarily the same as the specified default!)
		if( $$rec[2] eq ":s" ) {
		    $val = "";
		}
		elsif( $$rec[2] eq ":i" ) {
		    $val = 0;
		}
		elsif( $$rec[2] eq ":b" ) {
		    $val = 1;
		}
		else {
		    carp "Warning: don't know default for $$rec[2]";
		    $val = "";
		}
	    }			# end bare block
	}
	else {
	    # mandatory parameter
	    unless( @$argvref && $$argvref[0] ne '--' ) {
		print STDERR "Error: Option $opt is not followed by a value\n" ;
		exit(5);
	    }
	    $val = $$argvref[0];
	    if( $$rec[2] eq "=i" && $val !~ /-?\d+/ ) {
		print STDERR "Option $opt: $val is not an integer\n";
		exit(5);
	    }
	    if( $$rec[3] ) {
		# value *must* pass subroutine test if available
		my $tval = &{$$rec[3]}( $val, $argvref, $$rec[-1] );
		unless( defined $val ) {
		    print STDERR "Value $val for option $opt not recognized\n";
		    # print help string if available
		    print STDERR $$rec[5] if defined $$rec[5];
		    exit 2;
		}
		$val = $tval;
	    }
	    shift @$argvref;
	}
	$self->{ $$rec[-1] } = $val;
    }
    # Now check that all options are defined; those that are not get
    # values from the resource file (if available), or the supplied
    # default value.
    my $rec;
    my $rcstuffref = _parse_rc_file( $optref, $rcfilename );
    foreach $rec ( @$optref ) {
	unless( defined $self->{ $$rec[-1] } ) {
	    my $val;
	    # not on command line, in rcfile?
	    if( defined ( $val = $rcstuffref->{ $$rec[-1] } ) ) {
		$self->{ $$rec[-1] } = $val;
	    }
	    # not in rcfile either, but you did supply a default, didntya?
	    else {
		die "Every option should have a default" unless defined $$rec[4];
		$self->{ $$rec[-1] } = $$rec[4];
	    }
	}
    }
    return $self;
}

1;