#!/usr/bin/perl -w
use strict;
use Test;
# First check that the module loads OK.
use vars qw($loaded);
BEGIN { $| = 1; plan tests => 18; }
END {print "not ok 1\n" unless $loaded;}
use Mail::Field::Received;
print "! Testing module load ...\n";
ok(++$loaded);
use Data::Dumper;
print "! Testing constructor ...\n";
my $received = Mail::Field->new('Received');
ok($received);
ok($received->tag(), 'Received');
print "! Testing setting debug level ...\n";
$received->debug(5);
ok($received->debug(), 5);
print "! Testing parsing ...\n";
my $in = 'from tr909.mediaconsult.com (mediacons.tecc.co.uk [193.128.6.132]) by host5.hostingcheck.com (8.9.3/8.9.3) with ESMTP id VAA24164 for <adam@spiers.net>; Tue, 1 Feb 2000 21:57:18 -0500';
print "! date format 3\n";
ok($received->parse($in));
ok($received->parsed_ok());
my $parse_tree = {
'by' => {
'domain' => 'host5.hostingcheck.com',
'whole' => 'by host5.hostingcheck.com',
'comments' => [
'(8.9.3/8.9.3)'
],
},
'date_time' => {
'year' => 2000,
'week_day' => 'Tue',
'minute' => 57,
'day_of_year' => '1 Feb',
'month_day' => ' 1',
'zone' => '-0500',
'second' => 18,
'hms' => '21:57:18',
'date_time' => 'Tue, 1 Feb 2000 21:57:18 -0500',
'hour' => 21,
'month' => 'Feb',
'rest' => '2000 21:57:18 -0500',
'whole' => 'Tue, 1 Feb 2000 21:57:18 -0500'
},
'with' => {
'with' => 'ESMTP',
'whole' => 'with ESMTP'
},
'from' => {
'domain' => 'mediacons.tecc.co.uk',
'HELO' => 'tr909.mediaconsult.com',
'from' => 'tr909.mediaconsult.com',
'address' => '193.128.6.132',
'comments' => [
'(mediacons.tecc.co.uk [193.128.6.132])',
],
'whole' => 'from tr909.mediaconsult.com (mediacons.tecc.co.uk [193.128.6.132])
'
},
'id' => {
'id' => 'VAA24164',
'whole' => 'id VAA24164'
},
'comments' => [
'(mediacons.tecc.co.uk [193.128.6.132])',
'(8.9.3/8.9.3)'
],
'for' => {
'for' => '<adam@spiers.net>',
'whole' => 'for <adam@spiers.net>'
},
'whole' => 'from tr909.mediaconsult.com (mediacons.tecc.co.uk [193.128.6.132]) by host5.hostingcheck.com (8.9.3/8.9.3) with ESMTP id VAA24164 for <adam@spiers.net>; Tue, 1 Feb 2000 21:57:18 -0500'
};
my $equal = equal_hashes($parse_tree, $received->parse_tree());
ok($equal);
diagnose($received) unless $equal;
print "! date format 3 again\n";
$in = '(qmail 7119 invoked from network); 22 Feb 1999 22:01:53 -0000';
$received->parse($in);
ok($received->parsed_ok());
$parse_tree = {
'date_time' => {
'year' => 1999,
'week_day' => undef,
'minute' => '01',
'day_of_year' => '22 Feb',
'month_day' => 22,
'zone' => '-0000',
'second' => 53,
'date_time' => '22 Feb 1999 22:01:53 -0000',
'hms' => '22:01:53',
'hour' => 22,
'month' => 'Feb',
'rest' => '1999 22:01:53 -0000',
'whole' => '22 Feb 1999 22:01:53 -0000'
},
'comments' => [
'(qmail 7119 invoked from network)'
],
'whole' => '(qmail 7119 invoked from network); 22 Feb 1999 22:01:53 -0000'
};
$equal = equal_hashes($parse_tree, $received->parse_tree());
ok($equal);
diagnose($received) unless $equal;
print "! date format 1\n";
my $new_date = '22 Feb';
my $new_rest = '22:01:53 1999 -0000';
my $new_date_time = "$new_date $new_rest";
$in = "(qmail 7119 invoked from network); $new_date_time";
$received->parse($in);
ok($received->parsed_ok());
$parse_tree->{date_time}{whole} = $new_date_time;
$parse_tree->{date_time}{date_time} = $new_date_time;
$parse_tree->{date_time}{rest} = $new_rest;
$parse_tree->{whole} = $in;
$equal = equal_hashes($parse_tree, $received->parse_tree());
ok($equal);
diagnose($received) unless $equal;
print "! date format 2\n";
$new_date = '22 Feb';
$new_rest = '22:01:53 -0000 1999';
$new_date_time = "$new_date $new_rest";
$in = "(qmail 7119 invoked from network); $new_date_time";
$received->parse($in);
ok($received->parsed_ok());
$parse_tree->{date_time}{whole} = $new_date_time;
$parse_tree->{date_time}{date_time} = $new_date_time;
$parse_tree->{date_time}{rest} = $new_rest;
$parse_tree->{whole} = $in;
$equal = equal_hashes($parse_tree, $received->parse_tree());
ok($equal);
diagnose($received) unless $equal;
print "! Testing different constructor method ...\n";
$in = 'from lists.securityfocus.com (lists.securityfocus.com [207.126.127.68]) by lists.securityfocus.com (Postfix) with ESMTP id 1C2AF1F138; Mon, 14 Feb 2000 10:24:11 -0800 (PST)';
my $received2 = Mail::Field->new('Received', $in);
ok($received2->parsed_ok());
$parse_tree = {
'by' => {
'domain' => 'lists.securityfocus.com',
'whole' => 'by lists.securityfocus.com',
'comments' => [
'(Postfix)'
],
},
'date_time' => {
'year' => 2000,
'week_day' => 'Mon',
'minute' => 24,
'day_of_year' => '14 Feb',
'month_day' => 14,
'zone' => '-0800 (PST)',
'second' => 11,
'date_time' => 'Mon, 14 Feb 2000 10:24:11 -0800 (PST)',
'hour' => 10,
'hms' => '10:24:11',
'month' => 'Feb',
'rest' => '2000 10:24:11 -0800 (PST)',
'whole' => 'Mon, 14 Feb 2000 10:24:11 -0800 (PST)'
},
'with' => {
'with' => 'ESMTP',
'whole' => 'with ESMTP'
},
'from' => {
'domain' => 'lists.securityfocus.com',
'from' => 'lists.securityfocus.com',
'HELO' => 'lists.securityfocus.com',
'address' => '207.126.127.68',
'comments' => [
'(lists.securityfocus.com [207.126.127.68])',
],
'whole' => 'from lists.securityfocus.com (lists.securityfocus.com [207.126.127.68])
'
},
'id' => {
'id' => '1C2AF1F138',
'whole' => 'id 1C2AF1F138'
},
'comments' => [
'(lists.securityfocus.com [207.126.127.68])',
'(Postfix)'
],
'whole' => 'from lists.securityfocus.com (lists.securityfocus.com [207.126.127.68]) by lists.securityfocus.com (Postfix) with ESMTP id 1C2AF1F138; Mon, 14 Feb 2000 10:24:11 -0800 (PST)'
};
$equal = equal_hashes($parse_tree, $received2->parse_tree());
ok($equal);
diagnose($received2) unless $equal;
print "Testing stringify() ...\n";
ok($received2->stringify(), $in);
print "Testing diagnostics code ...\n";
ok($received2->diagnostics()); # bit difficult to check this one properly
$received2->diagnose('squr', 'gle');
ok($received2->diagnostics(), '/squrgle/');
exit 0;
##############################################################################
sub equal_hashes {
my ($a, $b) = @_;
my @a = sort keys %$a;
my @b = sort keys %$b;
while (my $p = shift @a and my $q = shift @b) {
# print "Comparing `$p' and `$q' ...\n";
if (defined($p) xor defined($q)) {
print "first key undefined\n" unless defined($p);
print "second key undefined\n" unless defined($q);
return 0;
}
if ($p ne $q) {
print "`$p' ne `$q'\n";
return 0;
}
if (defined($a->{$p}) xor defined($b->{$q})) {
print "first value (key `$p') undef\n" unless defined($a->{$p});
print "second value (key `$q') undef\n" unless defined($b->{$q});
return 0;
}
elsif (! defined($a->{$p}) and ! defined($b->{$q})) {
next;
}
elsif (ref($a->{$p}) ne ref($b->{$q})) {
print "ref mismatch on values for `$p' and `$q'\n";
return 0;
}
elsif (ref($a->{$p}) eq 'HASH') {
# recursion rules
return 0 unless equal_hashes($a->{$p}, $b->{$q});
}
elsif (ref($a->{$p}) eq 'ARRAY') {
return 0 unless equal_arrays($a->{$p}, $b->{$q});
}
elsif (ref($a->{$p})) {
die "found unsupported type of ref\n" .
"(value of `$p' was " . ref($a->{$p}) . " ref)";
}
else {
if ($a->{$p} ne $b->{$q}) {
print "key `$p': `$a->{$p}' ne `$b->{$q}'\n";
return 0;
}
}
}
return 1;
}
sub equal_arrays {
my ($a, $b) = @_;
local $^W = 0; # silence spurious -w undef complaints
if (@$a != @$b) {
print "Arrays of different length:\n", (Dumper $a), (Dumper $b);
return 0;
}
for (my $i = 0; $i < @$a; $i++) {
# print "Comparing `$a->[$i]' and `$b->[$i]' ...\n";
return 0 if $a->[$i] ne $b->[$i];
}
return 1;
}
sub diagnose {
my ($received) = @_;
print <<EOF;
Diagnostics:
============
EOF
print $received->diagnostics();
print <<EOF;
Parse tree:
===========
EOF
print Dumper $received->parse_tree();
print "\n";
}
syntax highlighted by Code2HTML, v. 0.9.1