The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.

# $Id: score.t,v 1.3 2005/03/22 16:07:31 lem Exp $

# Check the basic scoring of the reports

use IO::File;
use Test::More;
use File::Path;
use Date::Parse;
use NetAddr::IP;
use Mail::Abuse::Reader;
use Mail::Abuse::Report;
use Mail::Abuse::Incident;

@incidents = 
    (
     ['172.16.64.25/32', 'Tue Jul 30 14:48:42 1996', 'test/foobar'],
     ['172.16.64.25/32', 'Tue Jul 30 14:48:42 1996', 'test/foobaz'],
     ['172.16.64.25/32', 'Tue Jul 30 14:48:42 1996', 'test/bazbar'],
     );

my @cases =
    (
     [ '1 All\syour\sbase', undef, [1] ],
     [ '7 All\syour\sbase', undef, [7] ],
     [ '1 all\syour\sbase', undef, [0] ],
     [ undef, '1 ^test/', [3] ],
     [ undef, '7 baz', [14] ],
     [ undef, '7 baz 5 foo', [24] ],
     [ '7 All\syour\sbase', '7 baz', [21] ],
     [ '5 All\syour\sbase', '7 baz 5 foo', [29] ],
     [ undef, undef, [0] ],
     [ '11000 All\syour\sbase', undef, [10000] ],
     [ '-11000 All\syour\sbas', undef, [-10000] ],
     );

				# Some funny helper classes
package myReader;
use base 'Mail::Abuse::Reader';
sub read { my $text = "All your base are belong to us!";
	   $_[1]->text(\$text); return 1 }

package myIncident;
use base 'Mail::Abuse::Incident';
sub new { bless {}, ref $_[0] || $_[0] };

package myParser;
use base 'Mail::Abuse::Incident';
sub parse {
    my @incidents = ();

    for my $i (@main::incidents)
    {
	my $I = new myIncident;
	$I->ip		(new NetAddr::IP $i->[0]);
	$I->time	($i->[1]);
	$I->type	($i->[2]);
	push @incidents, $I;
    }

    return @incidents;
};

package main;

my $config	= "config$$";	# Fake config

sub write_config ($$)		# Produce a suitable config file for testing
{
    my $r_re = shift;
    my $i_re = shift;
    my $fh = new IO::File;
    $fh->open($config, "w")
	or diag "Failed to create test config file: $!";
    print $fh "score report text: $r_re\n" if $r_re;
    print $fh "score incident type: $i_re\n" if $i_re;
    print $fh "score maximum value: 10000\n";
    print $fh "score minimum value: -10000\n";
    print $fh "# debug score: 1\n";
    $fh->close;
}

END { unlink $config };

plan tests => 1 + 3 * @cases;

use_ok('Mail::Abuse::Processor::Score');

my $rep;

for my $c (@cases)
{
    write_config($c->[0], $c->[1]);

    $rep = new Mail::Abuse::Report
    {
	config		=> $config,
	reader		=> new myReader,
	parsers		=> [ new myParser ],
	processors	=> [ new Mail::Abuse::Processor::Score ],
    };

    isa_ok($rep, 'Mail::Abuse::Report');
    $rep->next;
    ok(defined $rep->score, "Score is defined");
    unless (is($rep->score, $c->[2]->[0], "Score matches expected value"))
    {
	diag "Incident text: '" . ${$rep->text} . "'";
	diag "Report config: '" . $c->[0] . "'";
	diag "Incident config: '" . $c->[1] . "'";
    }
}