package GO::TestSet;

use strict;
use lib '/Users/gwg/go/scratch/tools';
use vars qw($AUTOLOAD @ISA @EXPORT_OK %EXPORT_TAGS);

use Carp;
#use Exporter;
use Email::Valid;
use Scalar::Util qw(blessed);
use Data::Dumper;
use GO::MsgLite;
require Exporter;
@ISA = ('Exporter');

@EXPORT_OK = qw(dfv_test test_param test);

%EXPORT_TAGS = ( all => [ @EXPORT_OK ] );


my $tests = {

is_a_string_p => {
	text => 'a string',
	fn => sub {
		my $args = shift;
		my $p = $args->{p};
	#	warn "function ".(caller(0))[3]." requires an argument: $!" if ! defined $p;
		return 1 if length($p) && $p =~ /\w/;
		return 0;
	},
},

is_an_url_p => {
	text => 'an url',
	fn => sub {
		my $args = shift;
		my $p = $args->{p};
	#	warn "function ".(caller(0))[3]." requires an argument: $!" if ! defined $p;
		return 1 if length($p) && $p =~ /^(https?|ftp):\/\/[a-zA-Z0-9\-\_\:\_\/\.\~\?\&\#\=\;\|\[\]\(\)\+]{5,}$/;
		return 0;
	},
},

is_an_email_address_p => {
	text => 'an email address',
	fn => sub {
		my $args = shift;
		my $p = $args->{p};
	#	warn "function ".(caller(0))[3]." requires an argument: $!" if ! defined $p;
		return 1 if length($p) && Email::Valid->address($p);
		return 0;
	},
},

is_a_number_p => {
	text => 'a number',
	fn => sub {
		my $args = shift;
		my $p = $args->{p};
	#	warn "function ".(caller(0))[3]." requires an argument: $!" if ! defined $p;
		return 1 if length($p) && $p =~ /^[0-9]+$/;
		return 0;
	},
},

is_a_date_p => {
	text => 'a date',
	fn => sub {
		my $args = shift;
		my $p = $args->{p};
	#	warn "function ".(caller(0))[3]." requires an argument: $!" if ! defined $p;
		return 1 if length($p) && $p =~ /\d{1,2}\-\d{1,2}\-(19|20)\d\d/;
		return 0;
	},
},

is_xref_like_p => {
	text => 'cross-reference-like',
	fn => sub {
		my $args = shift;
		my $p = $args->{p};
#		print STDERR "starting ".(caller(0))[3]." with string $p\n";
		return 1 if $p =~ /.+:.+/;
		return 0;
	},
},

is_true_p => {
	text => 'true',
	fn => sub {
		my $args = shift;
		my $p = $args->{p};
	#	print STDERR "string: ".Dumper($p)."\n";
		return 1 if $p && ($p eq '1' || $p eq 'true' || $p eq 'on');
		return 0;
	},
},

is_false_p => {
	text => 'false',
	fn => sub {
		my $args = shift;
		my $p = $args->{p};
		return 1 if $p && ($p eq '0' || $p eq 'false' || $p eq 'off');
		return 0;
	},
},

is_always_true => {
#	text => '',
	fn => sub {
		return 1;
	},
},

is_in_list_p => {
#	text => 'in the list',
	fn => sub {
		my $args = shift;

#		print STDERR "args: ".Dumper($args)."\n";

		my $list = $args->{list};
		my $p = $args->{p};
#		print STDERR "caller: ". join(" ", caller) . "; list = ".Dumper($list)." value = ".Dumper($p)."\n";
	#	make sure we have a list and a value to look for
		return 0 if (!$list || !@$list || !$p);
		
		foreach (@$list)
		{	return 1 if $p eq $_;
		}
		return 0;
	},
},

is_not_in_list_p => {
#	text => 'not in the list',
	fn => sub {
		my $args = shift;
		my $list = $args->{list};
		my $p = $args->{p};
		
		foreach (@$list)
		{	return 0 if $p eq $_;
		}
		return 1;
	},
},

is_in_string_p => {
#	text => 'in the string',
	fn => sub {
		my $args = shift;
		my $string = $args->{string};
		my $p = $args->{p};
		
#		print STDERR "string: $string; p: $p\n";
#		warn "function ".(caller(0))[3]." requires two scalar arguments: $!" if ! defined $string || ! defined $p ||  ref($string) || ref($p);
#		$string = qq/$string/;
#		$p = qq/$p/;

#		print STDERR "string: ".Dumper($string) ."p: $p\n";

		return 1 if $string =~ /\Q$p\E/ism;
#		return 1 if lc($p) =~ /\Q$string\E/ism;
		return 0;
	},
},

is_in_string_switched_p => {
#	text => 'not in the string',
	fn => sub {
		my $args = shift;
		my $string = $args->{string};
		my $p = $args->{p};
		
#		warn "function ".(caller(0))[3]." requires two scalar arguments\n" if ! defined $string || ! defined $p ||  ref($string) || ref($p);
#		$string = lc( qq/$string/ );
#		$p = lc ( qq/$p/ );

#		print STDERR "string: ".Dumper($string) ."p: $p\n";

		return 1 if $p =~ /$string/ism; # || $string =~ /$p/ism;
		return 0;
	},

},

is_in_string_cs_p => {
	# case-sensitive version of the above
#	text => 'in the string',
	fn => sub {
		my $args = shift;
		my $string = $args->{string};
		my $p = $args->{p};
		
	#	print STDERR "string: $string; substr: $p\n";
#		warn "function ".(caller(0))[3]." requires two scalar arguments: $!" if ! defined $string || ! defined $p ||  ref($string) || ref($p);
		return 1 if $string =~ /\Q$p\E/sm;
		return 0;
	},
},

is_the_same_as_p => {
#	text => 'the same as',
	fn => sub {
		my $args = shift;
		my $string = $args->{string};
		my $p = $args->{p};
		
#		warn "function ".(caller(0))[3]." requires two scalar arguments: $!" if ! defined $string || ! defined $p ||  ref($string) || ref($p);

		return 1 if $string eq $p;
		return 0;
	},

},

is_the_same_as_lc_p => {
	# non-case sensitive version of the above
#	text => 'the same as',
	fn => sub {
		my $args = shift;
		my $string = $args->{string};
		my $p = $args->{p};
		
#		warn "function ".(caller(0))[3]." requires two scalar arguments: $!" if ! defined $string || ! defined $p ||  ref($string) || ref($p);
		return 1 if lc($string) eq lc($p);
		return 0;
	},
},

is_ref_type_p => {
#	text => '',
	fn => sub {
		my $args = shift;
		my $type = $args->{type};
		my $p = $args->{p};
		
		if (lc(ref($p)) eq lc($type))
		{	return 1;
		}
		elsif (!ref($p) && lc($type) eq 'scalar')
		{	return 1;
		}
		return;
	},
},

is_a_subclass_of_p => {
#	text => '',
	fn => sub {
#		print STDERR "starting is_a_subclass_of_p with caller ".(caller(0))[3]."\n";
		my $args = shift;
		my $class = $args->{class};
		my $p = $args->{p};

#		print STDERR "object: ".Dumper($object)."\n";
#		print STDERR "class: ".Dumper($class)."\n";

		if ( blessed ($p) )
		{	if ($p->isa($class))
			{	return 1;
			}
			return 0;
		}
		warn "argument $p is not an object!";
	},
	
},

is_lt_p => {
	# p is less than the number
	text => sub { my $args = shift; return 'less than' . $args->{n}; },
	fn => sub {
		my $args = shift;
		my $num = $args->{n};
		my $p = $args->{p};
		return 1 if $p < $num;
		return;
	},

},

is_gt_p => {
	# p is greater than the number
	text => sub { my $args = shift; return 'greater than' . $args->{n}; },
	fn => sub {
		my $args = shift;
		my $num = $args->{n};
		my $p = $args->{p};
		return 1 if $p > $num;
		return;
	},
},

is_eq_p => {
	text => sub { my $args = shift; return 'equal to' . $args->{n}; },
	fn => sub {
		my $args = shift;
		my $num = $args->{n};
		my $p = $args->{p};
		return if $p != $num;
		return 1;
	},
},

is_greater_than_p => {
	text => sub { my $args = shift; return 'a number greater than' . $args->{n}; },
	fn => sub {
		my $args = shift;
		my $num = $args->{n};
		my $p = $args->{p};
		return unless (test('is_a_number_p', { p => $num }) && test('is_a_number_p', { p => $p }) && $p > $num);
		return 1;
	},
},

is_greater_than_or_equal_to_p => {
	text => sub { my $args = shift; return 'a number greater than or equal to' . $args->{n}; },
	fn => sub {
		my $args = shift;
		my $num = $args->{n};
		my $p = $args->{p};
		return unless (test('is_a_number_p', { p => $num }) && test('is_a_number_p', { p => $p }) && $p >= $num );
		return 1;
	},
},

is_less_than_p => {
	text => sub { my $args = shift; return 'a number less than ' . $args->{n}; },
	fn => sub {
		my $args = shift;
		my $num = $args->{n};
		my $p = $args->{p};
		return unless (test('is_a_number_p', { p => $num }) && test('is_a_number_p', { p => $p }) && $p < $num);
		return 1;
	},
},

is_less_than_or_equal_to_p => {
	text => sub { my $args = shift; return 'a number less than or equal to '. $args->{n}; },
	fn => sub {
		my $args = shift;
		my $num = $args->{n};
		my $p = $args->{p};
		return unless (test('is_a_number_p', { p => $num }) && test('is_a_number_p', { p => $p }) && $p <= $num);
		return 1;
	},
},

is_number_between_p => {
	text => sub {
		my $args = shift;
		return 'a number between ' . $args->{min}.' and '. $args->{max};
	},
	fn => sub {
		my $args = shift;
		my $p = $args->{p};
		my $min = $args->{min};
		my $max = $args->{max};
		my $inc = $args->{inc};

		return unless (
			test('is_a_number_p', { p => $p }) &&
			test('is_a_number_p', { p => $min }) &&
			test('is_a_number_p', { p => $max }));

		# if the test is inclusive and p == min or max
		if (($inc && ($p == $min || $p == $max))
		# p is greater than min and smaller than max
			|| ($min < $p && $p < $max))
		{	return 1;
		}
		return;
	},
},

};




# this is the method used to perform the test
sub test {
#	print STDERR "test variables: ".Dumper(\@_)."\n";
#	my $self = shift;
	my $test_name = shift;
	
	if (ref($test_name) eq 'HASH')
	{	$test_name = $test_name->{test_name};
	}

	if (exists $tests->{$test_name}{fn})
	{	
		return $tests->{$test_name}{fn}->(@_);
	}

	warn "Test $test_name is not defined. Arses!";
}

## As test, but with the value to be tested as a scalar in $_[-1]
sub test_param {
	my $test_name = shift;
	my @args = @_;
	
	# if there are no args, run the test anyway
	return $tests->{$test_name}{fn} if ! @args;

	# otherwise, remove $p and put it into the previous @args entry
	my $p = pop @args;

	if (! @args)
	{	return $tests->{$test_name}{fn}->({ p => $p });
	}
	elsif ( ref($args[-1]) ne 'HASH' )
	{	# bollocks! Now what are we going to do?!
		warn "Error! args[-1] is not a hash! Need help";
		return $tests->{$test_name}{fn}->(@args, { p => $p });
	}
	else
	{	$args[-1]{p} = $p;
		return $tests->{$test_name}{fn}->(@args);
	}
}

## DFV interface
sub dfv_test {
#	my $self = shift;
	my $test_name = shift;
	my $params = shift;
#	print STDERR "Prepping dfv_test $test_name\ncaller: ".
#	join( "; ", map { (caller($_))[3] } (0, 1, 2, 3, 4, 5) )
#	."\nparams: ".Dumper($params)."\n\n";

#	if ($test_name =~ /is_(xref_like|a_subclass_of)/)
#	{	print STDERR "$test_name params: ".Dumper(@params)."\n";
#	}

	return sub {
		my $dfv = shift;
		
		# Name it to refer to in the 'msgs' system.
		$dfv->name_this($dfv->get_current_constraint_field . "_" . $test_name);

if ($test_name eq 'is_in_list_p')
{	#print STDERR "params BEFORE: ".Dumper($params);
}
		my $dfv_data;
		if ( ! $params || ! defined $params )  # assume that the current object is the parameter
		{	#print STDERR "No params found! getting the current constraint value\n";
			$params = { p => $dfv->get_current_constraint_value };
		}
		else
		{	# convert any other stuff in the param_h
			if ($params)
			{	if ($params->{this})
				{	$params->{p} = $dfv->get_current_constraint_value();
					#delete $params->{this};
				}
				elsif ($params->{param})
				{	$dfv_data = $dfv->get_filtered_data if !$dfv_data;
					if (!ref($params->{param}))
					{	$params->{param} = [ $params->{param} ];
					}
					push @{$params->{p}}, $dfv_data->{$_} foreach @{$params->{param}};
				}
				elsif ($params->{all_params})
				{	$params->{p} = $dfv->get_filtered_data;
				}
				elsif ($params->{input_data})
				{	$params->{p} = $dfv->get_input_data( as_hashref => 1 );
				}

				if ($params->{p} && $params->{p} ne $dfv->get_current_constraint_value())
				{	#print STDERR "p not equal to current constr value!!\n";
					$params->{p} = $dfv->get_current_constraint_value();
				}

			}
			
			
		}
#		print STDERR "params NOW: ".Dumper($params) if $test_name eq 'is_in_list_p';
		return test($test_name, $params);
	};
}

# get a text string of the test name
sub test_name {
	my $test_name = shift;
	
	if (ref($test_name) eq 'HASH')
	{	$test_name = $test_name->{test_name};
	}

	if (exists $tests->{$test_name}{text})
	{	if (! ref($tests->{$test_name}{text}))
		{	return $tests->{$test_name}{text};
		}
		else
		{	return $tests->{$test_name}{text}->(@_);
		}
	}

	warn "Test $test_name's text is not defined. Arses!";
}







sub AUTOLOAD {
	my $self = shift;
	my $name = $AUTOLOAD;
	print STDERR "Object::AUTOLOAD name: ".Dumper($name)."\n";
	return if $name =~ /DESTROY/;

	$name =~ s/^.*:://;   # strip fully-qualified portion

	if (exists $tests->{$name})
	{	return $tests->{$name}->(@_);
	}
	else
	{	warn "Can't do $name with GO::TestSet!";
	}
}

1;