HTTP::WebTest::Plugin - Base class for HTTP::WebTest plugins.

    'param1 type1
     param2 type2
     param3 type3(optional,args)
     param4 type4'

    ('TYPE_1', 'TYPE_2', ..., 'TYPE_N')

    ('TYPE_1', 'TYPE_2', ..., 'TYPE_M', '...')

    check_scalar($param, $value, '^(?:yes|no)$');

# $Id: Plugin.pm,v 1.14 2003/03/02 11:52:10 m_ilya Exp $

package HTTP::WebTest::Plugin;

use strict;

use HTTP::WebTest::TestResult;
use HTTP::WebTest::Utils qw(make_access_method);

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;

    my $self = bless {}, $class;

    my $webtest = shift;

    $self->webtest($webtest);

    return $self;
};

*webtest = make_access_method('WEBTEST');

sub global_test_param {
    my $self = shift;
    my $param = shift;
    my $default = shift;

    my $value = $self->webtest->global_test_param($param);

    my $ret = defined $value ? $value : $default;

    return $self->_canonic_value($ret);
}

sub test_param {
    my $self = shift;
    my $param = shift;
    my $default = shift;

    my $global_value = $self->webtest->global_test_param($param);

    my $value;
    if(defined $self->webtest->current_test) {
	$value = $self->webtest->current_test->param($param);
	$value = defined $value ? $value : $global_value;
    } else {
	$value = $global_value;
    }

    my $ret = defined $value ? $value : $default;

    return $self->_canonic_value($ret);
}

sub global_yesno_test_param {
    my $self = shift;
    my $param = shift;
    my $default = shift || 0;

    my $value = $self->global_test_param($param);

    return $default unless defined $value;
    return $value =~ /^yes$/i;
}

sub yesno_test_param {
    my $self = shift;
    my $param = shift;
    my $default = shift || 0;

    my $value = $self->test_param($param);

    return $default unless defined $value;
    return $value =~ /^yes$/i;
}

# reference on hash that caches return value of subroutine calls
*_sub_cache = make_access_method('_SUB_CACHE', sub { {} });

# searches passed data structure for code references and replaces them
# with value returned by referenced subs
sub _canonic_value {
    my $self = shift;
    my $value = shift;

    if(ref($value) eq 'CODE') {
	# check if value is in cache; value returned from subroutine
	# is cached so we don't evaluate test parameter value more
	# than one time
	unless(${$self->_sub_cache}{$value}) {
	    ${$self->_sub_cache}{$value} = $value->($self->webtest);
	}

	$value = ${$self->_sub_cache}{$value};
    }

    if(ref($value) eq 'ARRAY') {
	$value = [ map $self->_canonic_value($_), @$value ];
    } elsif(ref($value) eq 'HASH') {
	for my $key (keys %$value) {
	    $value->{$key} = $self->_canonic_value($value->{$key});
	}
    }

    return $value;
}

sub test_result {
    my $self = shift;
    my $ok = shift;
    my $comment = shift;

    my $result = HTTP::WebTest::TestResult->new;
    $result->ok($ok);
    $result->comment($comment);

    return $result;
}

# helper method used by validate_params and by global_validate_params
# to validate values of test parameters
sub _validate_params {
    my $self = shift;
    my %params = @_;

    my %param_types = grep $_ =~ /\S/, split /\s+/, $self->param_types;

    while(my($param, $value) = each %params) {
	next unless defined $value;

	my $type = $param_types{$param};
	die "HTTP::WebTest: unknown test parameter '$param'"
	    unless defined $type;

	$self->validate_value($param, $value, $type);
    }
}

sub validate_params {
    my $self = shift;
    my @params = @_;

    my %params = ();
    for my $param (@params) {
	$params{$param} = $self->test_param($param);
    }

    $self->_validate_params(%params);
}

sub global_validate_params {
    my $self = shift;
    my @params = @_;

    my %params = ();
    for my $param (@params) {
	$params{$param} = $self->global_test_param($param);
    }

    $self->_validate_params(%params);
}

sub validate_value {
    my $self = shift;
    my $param = shift;
    my $value = shift;
    my $type = shift;

    # parse param type specification
    my($method, $args) = $type =~ /^ (\w+) (?: \( (.*?) \) )? $/x;
    die "HTTP::WebTest: bad type specification '$type'"
	unless defined $method;
    $method = 'check_' . $method;

    # get additional arguments for type validation sub
    $args = '' unless defined $args;
    my @args = eval " ( $args ) ";
    die "HTTP::WebTest: can't eval args '$args': $@"
	if $@;

    $self->$method($param, $self->_canonic_value($value), @args);
}

sub param_types { '' }

sub check_anything { 1 }

sub check_list {
    my $self = shift;
    my $param = shift;
    my $value = shift;
    my @spec = @_;

    die "HTTP::WebTest: parameter '$param' is not a list"
	unless ref($value) eq 'ARRAY';

    return unless @spec;

    my @list = @$value;
    my $prev_type = undef;
    for my $i (0 .. @list - 1) {
	my $type = shift @spec;

	die "HTTP::WebTest: too many elements in list parameter '$param'"
	    unless defined $type;

	if($type eq '...') {
	    $type = $prev_type;
	    push @spec, '...';
	}

	my $elem = $list[$i];

	$self->validate_value("$param\[$i]", $elem, $type);

	$prev_type = $type;
    }

    shift @spec if defined $spec[0] and $spec[0] eq '...';

    die "HTTP::WebTest: too few elements in list parameter '$param'"
	if @spec;
}

sub check_scalar {
    my $self = shift;
    my $param = shift;
    my $value = shift;
    my $optional_regexp = shift;

    die "HTTP::WebTest: parameter '$param' is not a scalar"
	unless not ref($value);

    return unless defined $optional_regexp;

    die "HTTP::WebTest: parameter '$param' doesn't match regexp '$optional_regexp'"
	unless $value =~ /$optional_regexp/i;
}

sub check_stringref {
    my $self = shift;
    my $param = shift;
    my $value = shift;

    die "HTTP::WebTest: parameter '$param' is not a scalar reference"
	unless ref($value) eq 'SCALAR';
}

sub check_uri {
    my $self = shift;
    my $param = shift;
    my $value = shift;

    my $ok = 1;
    eval { $self->check_scalar($param, $value) };
    if($@) {
	$ok = 0
	    unless defined ref($value) and UNIVERSAL::isa($value, 'URI');
    }

    die "HTTP::WebTest: parameter '$param' is not a URI"
	unless $ok;
}

sub check_hashlist {
    my $self = shift;
    my $param = shift;
    my $value = shift;

    my $ok = 1;
    eval { $self->check_list($param, $value) };
    if($@) {
	$ok = 0
	    unless ref($value) eq 'HASH';
    } else {
	$ok = 0
	    unless (@$value % 2) == 0;
    }

    die "HTTP::WebTest: parameter '$param' is neither a hash nor a list with even number of elements"
	unless $ok;
}

sub check_yesno {
    my $self = shift;
    my $param = shift;
    my $value = shift;

    check_scalar($param, $value, '^(?:yes|no)$');
}

1;