package CheckOptions;

=head1 NAME

check_options - Check a hash for valid/required values.

=head1 SYNOPSIS

 use CheckOptions;

 $n_errors = check_options(
   -values    => \%hash,
   -valid     => \@valid_keys,
   -required  => \@required_keys,
 );

=head1 DESCRIPTION

C<check_options()> is a primitive function key => value checker, typically
used to check whether a function was passed valid key/value pairs; there is
currently no way to check the key values for validity.

C<check_options()> returns the number of tests that failed (each
required/valid option and reference type is a "test"), after printing warning
messages explaining each failed test.  The function itself will print a stack
trace and raise an exception if it is used with invalid arguments.

=head1 OPTIONS

=over 4

=item B<-values =E<gt>> values to check against

Hash reference, required.  This is typically a reference to the hash that was
passed to your subroutine.

=item B<-valid =E<gt>> keys in -values that are valid

Array reference, optionalE<40>*E<41>.  Each element in the array is a valid
key to the -values hash.

=item B<-required =E<gt>> keys in -values that are required

Array reference, optionalE<40>*E<41>.  Each element in the array is a required
key in the -values hash.

=back

B<(*)> Keys in -required are automatically added to -valid, which means that
either -valid or -required is optional, but one of them must be used.

The last character of the elements in -valid and -required can be a type of
reference required for that key:

=over 4

=item B<$> = SCALAR

=item B<@> = ARRAY

=item B<%> = HASH

=item B<&> = CODE

=item B<*> = GLOB

=item B<.> = No Reference (e.g. A literal string or simple scalar.)

=back

If none of these characters are used, anything is accepted for that key.

=head1 EXAMPLES

 sub foo(%)
 {
   my %args = @_;

   return 0 if check_options(
     -values   = \%args,
     -required = ['-bar%', '-baz@'],
     -valid    = [qw(-thud. -grunt)]
   );

   [...]
 }

In this example, foo is hopefully passed a hash which is passed to
check_options as a reference (-values = \%args).

That hash is checked to see if it has the required keys "-bar", which requires
a hash reference to be passed to it, and "-baz", which requires an array
reference to be passed to it.

The optional argument "-thud" can't have a reference passed to it, and
"-grunt" doesn't care what it gets.

If any of these tests fail, foo will return false.

=head1 BUGS

If you try to pass a literal array/hash (not a reference) to check_options, it
will fail in interseting ways.  (The same goes for the subroutine you're using
check_options in, probably.)

=head1 AUTHOR

Christian J. Robinson <infynity@onewest.net>

=head1 COPYRIGHT

Copyright (C) March 01, 2002  Christian J. Robinson <infynity@onewest.net>

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.

=cut

use 5.004;

use strict;
use Exporter;
use Carp;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %types $types_pattern);

$VERSION = 0.2;

@ISA       = qw(Exporter);
@EXPORT    = qw(check_options);
@EXPORT_OK = qw();


sub check_options(%);
sub optparse(@);

# TODO : Add a way to add to/modify this list:
%types=(
	'$' => 'SCALAR',
	'@' => 'ARRAY',
	'%' => 'HASH',
	'&' => 'CODE',
	'*' => 'GLOB',
	'.' => 'No Reference',
);

$types_pattern = join('',keys %types);

sub check_options(%)
#############################################################################
# Purpose:
#   Check a hash for valid/required values.
# Arguments:
#   -values   => values to check against
#                (hash ref, required)
#   -valid    => keys in -values that are valid
#                (array ref, required if -required isn't specified)
#   -required => keys in -values that are required
#                (array ref, optional)
#
#   Any values in -required will also be included in -valid automatically.
#
# Return value:
#   Number of tests failed; 0 indicates success,
#   -1 if options to check_options() are invalid somehow.
#   (Each invalid argument or missing required argument is a test.)
#############################################################################
{
	my %options = @_;
	my $i = 0;
	my $caller=(caller(1))[3];
	my (%valid_keys, $valid_keys);
	local $! = 0;

	$i = check_options(
		-values   => \%options,
		-valid    => [qw(-valid@ -required@)],
		-required => [qw(-values%)],
	) unless $caller =~ m/(::)?check_options$/;

	if (! $options{'-valid'} && ! $options{'-required'})
	{
		carp "Missing key to ${caller}: -valid or -required";
		++$i
	}

	# If we have errors calling check_options from check_options, the programmer
	# probably totally biffed it; print a backtrace and exit:
	confess if $i;

	#my %required_keys = optparse(@{$options{'-required'}});
	($i, %valid_keys) = optparse(@{$options{'-valid'}}, @{$options{'-required'}});
	$valid_keys = join('|', keys %valid_keys);

	foreach my $key (keys %{$options{'-values'}})
	{
		#print "$caller $key : " . ref($options{'-values'}->{$key}) . "\n";

		my $type = ref($options{'-values'}->{$key});
		$type = 'No Reference' unless $type;

		if ($key !~ m/^($valid_keys)$/)
		{
			carp "Invalid key to ${caller}: $key";
			++$i;
		} elsif ($types{$valid_keys{$key}} && $types{$valid_keys{$key}} ne $type)
		{
			carp "Invalid reference type passed to key '$key' of ${caller}. " .
				"\n   Wanted: $types{$valid_keys{$key}} ($valid_keys{$key})" .
				"\n      Got: $type" .
				"\n";
			++$i;
		}
	}

	#foreach my $key (keys %required_keys)
	foreach my $key (@{$options{'-required'}})
	{
		# Don't modify the actual hash, but we need the key without special
		# identifiers at the end:
		my $key2;
		($key2 = $key) =~ s/[$types_pattern]$//;

		if (! $options{'-values'}->{$key2})
		{
			carp "Missing key to ${caller}: $key2";
			++$i;
		}
	}

	return($i);
}

sub optparse(@)
#############################################################################
# Purpose:
#   Parse an array into "types" and remove duplicates, warning of conflicting
#   types.
# Arguments:
#   Any array; as many arguments as you like.
# Return value:
#   The number of errors that occurred, and a hash containing the arguments
#   passed to it as the keys with their types as the key values, minus
#   duplicate arguments.
#############################################################################
{
	my (%ary, $val, $val2, $type);
	my $i = 0;
	my $caller=(caller(2))[3];

	# NOTE: Do not assign to $val, it's an alias to the actual arguments passed
	# to this function:
	foreach $val (@_)
	{
		if (($val2, $type) = $val =~ m/(.+)([$types_pattern])$/)
		{
			if ($ary{$val2} && $ary{$val2} ne $type)
			{
				carp "Warning: Conflicting reference types for key '$val2' in ${caller}: $ary{$val2}, $type";
				++$i;
			} else {
				$ary{$val2} = $type;
			}
		} elsif ($ary{$val})
		{
				carp "Warning: Conflicting reference types for key '$val' in ${caller}: $ary{$val}, (No Type)";
				++$i;
		} else {
			#++$ary{$val};
			$ary{$val} = '';
		}
	}

	return $i, %ary;
}

1;

# vim600:fdl=1