| 1 |
#!/usr/bin/perl |
| 2 |
# |
| 3 |
# File: test.pl |
| 4 |
# Author: James Couzens <jcouzens@codeshare.ca> (Maintainer) |
| 5 |
# Author: Wayne Schlitt <wayne@midwestcs.com> (Author) |
| 6 |
# Author: Meng Weng Wong <mengwengwong@pobox.com> (Original Author) |
| 7 |
# |
| 8 |
# Desc: |
| 9 |
# Originally designed to stress test any SPF implementation however |
| 10 |
# this particular implementation has long since been updated with any of Wayne's |
| 11 |
# code since he has added many "features" to his library which I disagree with. |
| 12 |
# We don't need features at this stage, we need stable code. Quite frankly, |
| 13 |
# we don't need any features, we just need what the RFC states. |
| 14 |
# |
| 15 |
# Date: 01/25/04 - based on the perl Mail-SPF-Query-1.99.tar |
| 16 |
# Date: 07/28/04 - Edit to use to spfqtool |
| 17 |
# Date: 10/07/04 - cleaned this mess up, no wonder people think perl is ugly |
| 18 |
# |
| 19 |
######################### |
| 20 |
|
| 21 |
use Test; |
| 22 |
use strict; |
| 23 |
|
| 24 |
use Getopt::Long; |
| 25 |
|
| 26 |
my $HELP = 0; |
| 27 |
my $SPFPROG = "./spfqtool_static"; |
| 28 |
my $SPFDATA = "test.txt"; |
| 29 |
my $VALGRIND = '/usr/bin/valgrind'; |
| 30 |
my $VG_OPTS = '--log-file=vg_test.txt --tool=memcheck --leak-check=yes --show-reachable=yes --num-callers=50 --trace-children=yes'; |
| 31 |
|
| 32 |
|
| 33 |
my $result = GetOptions( |
| 34 |
'help' => \$HELP, |
| 35 |
'program=s' => \$SPFPROG, |
| 36 |
'data=s' => \$SPFDATA, |
| 37 |
); |
| 38 |
|
| 39 |
if ($HELP || !$result) |
| 40 |
{ |
| 41 |
print <<EOF; |
| 42 |
Usage: apmiser [options] |
| 43 |
|
| 44 |
-help Help on the options. |
| 45 |
|
| 46 |
-program=/path/program Use an alternate spfqtool command. |
| 47 |
-data=/path/test.txt Use an alternate alternate test data |
| 48 |
EOF |
| 49 |
exit(0); |
| 50 |
} |
| 51 |
|
| 52 |
|
| 53 |
my @test_table; |
| 54 |
|
| 55 |
BEGIN |
| 56 |
{ |
| 57 |
open(TESTFILE, "test.txt"); |
| 58 |
|
| 59 |
@test_table = grep |
| 60 |
{ |
| 61 |
/\S/ and not /^\s*#/ |
| 62 |
} <TESTFILE>; |
| 63 |
|
| 64 |
chomp @test_table; |
| 65 |
close(TESTFILE); |
| 66 |
|
| 67 |
plan tests => (1 + @test_table); |
| 68 |
}; |
| 69 |
|
| 70 |
# 1: did the library load okay? |
| 71 |
ok(1); |
| 72 |
|
| 73 |
######################### |
| 74 |
|
| 75 |
foreach my $tuple (@test_table) |
| 76 |
{ |
| 77 |
my ($num, |
| 78 |
$domain, |
| 79 |
$ipv4, |
| 80 |
$expected_result, |
| 81 |
$expected_smtp_comment, |
| 82 |
$expected_header_comment) = $tuple =~ /\t/ ? split(/\t/, $tuple) : |
| 83 |
split(' ', $tuple); |
| 84 |
|
| 85 |
my ($sender, $localpolicy) = split(':', $domain, 2); |
| 86 |
|
| 87 |
$sender =~ s/\\([0-7][0-7][0-7])/chr(oct($1))/ge; |
| 88 |
$domain = $sender; |
| 89 |
|
| 90 |
if ($domain =~ /\@/) |
| 91 |
{ |
| 92 |
($domain) = $domain =~ /\@(.+)/ |
| 93 |
} |
| 94 |
|
| 95 |
if ($expected_result =~ /=(pass | fail),/) |
| 96 |
{ |
| 97 |
print "these tests are not implemented yet.\n"; |
| 98 |
|
| 99 |
for (my $debug = 0; $debug < 2; $debug++) |
| 100 |
{ |
| 101 |
last; |
| 102 |
|
| 103 |
my $query = ""; |
| 104 |
|
| 105 |
my $ok = 1; |
| 106 |
my $header_comment; |
| 107 |
|
| 108 |
foreach my $e_result (split(/,/, $expected_result)) |
| 109 |
{ |
| 110 |
if ($e_result !~ /=/) |
| 111 |
{ |
| 112 |
my ($msg_result, $smtp_comment); |
| 113 |
|
| 114 |
($msg_result, $smtp_comment, $header_comment) = |
| 115 |
eval |
| 116 |
{ |
| 117 |
$query->message_result2 |
| 118 |
}; |
| 119 |
|
| 120 |
# its this kind of code that makes people hate perl !@($*_#! |
| 121 |
$ok = ok($msg_result, $e_result) if (!$debug); |
| 122 |
|
| 123 |
if (!$ok) |
| 124 |
{ |
| 125 |
last; |
| 126 |
} |
| 127 |
} |
| 128 |
else |
| 129 |
{ |
| 130 |
my ($recip, $expected_recip_result) = split(/=/, $e_result, 2); |
| 131 |
|
| 132 |
my ($recip_result, $smtp_comment) = |
| 133 |
eval |
| 134 |
{ |
| 135 |
$query->result2(split(';',$recip)) |
| 136 |
}; |
| 137 |
|
| 138 |
$ok = ok($recip_result, $expected_recip_result) if (!$debug); |
| 139 |
|
| 140 |
if (!$ok) |
| 141 |
{ |
| 142 |
last; |
| 143 |
} |
| 144 |
} # else |
| 145 |
} # foreach |
| 146 |
|
| 147 |
$header_comment =~ s/\S+: //; # strip the reporting hostname prefix |
| 148 |
|
| 149 |
if ($expected_header_comment) |
| 150 |
{ |
| 151 |
$ok &= ok($header_comment, $expected_header_comment) if (!$debug); |
| 152 |
} |
| 153 |
|
| 154 |
last if ($ok); |
| 155 |
} # foreach |
| 156 |
|
| 157 |
} # if expected result |
| 158 |
else |
| 159 |
{ |
| 160 |
open(SPFQUERY, "$SPFPROG -i \"$ipv4\" -s \"$sender\" -h \"$domain\" -z 1 |"); |
| 161 |
|
| 162 |
my ($result, $smtp_comment, $header_comment); |
| 163 |
|
| 164 |
chomp($result = <SPFQUERY>); |
| 165 |
chomp($smtp_comment = <SPFQUERY>); |
| 166 |
chomp($header_comment = <SPFQUERY>); |
| 167 |
|
| 168 |
close(SPFQUERY); |
| 169 |
|
| 170 |
$header_comment =~ s/^\S+: //; # strip the reporting hostname prefix |
| 171 |
|
| 172 |
print "bin/spfqtool_static -i $ipv4 -s $sender -h $domain -z 1\n"; |
| 173 |
|
| 174 |
my $ok = (! $expected_smtp_comment |
| 175 |
? ok($result, $expected_result) |
| 176 |
: (ok($result, $expected_result) && |
| 177 |
ok($smtp_comment, $expected_smtp_comment) && |
| 178 |
ok($header_comment, $expected_header_comment))); |
| 179 |
|
| 180 |
if (not $ok) |
| 181 |
{ |
| 182 |
print "./spfqtool_static -i \"$ipv4\" -s \"$sender\" -h \"$domain\" -z 1 |\n"; |
| 183 |
|
| 184 |
printf "Result: %s\n", $result; |
| 185 |
printf "SMTP comment: %s\n", $smtp_comment; |
| 186 |
printf "Header comment: %s\n", $header_comment; |
| 187 |
|
| 188 |
open(SPFQUERY, "$SPFPROG -i \"$ipv4\" -s \"$sender\" -h \"$domain\" -z 1 |"); |
| 189 |
|
| 190 |
while(<SPFQUERY>) |
| 191 |
{ |
| 192 |
print $_; |
| 193 |
} |
| 194 |
|
| 195 |
close(SPFQUERY); |
| 196 |
|
| 197 |
if ($@) |
| 198 |
{ |
| 199 |
print " trapped error: $@\n"; |
| 200 |
next; |
| 201 |
} |
| 202 |
} # if (not $ok) |
| 203 |
} # else |
| 204 |
} # foreach |
| 205 |
|
| 206 |
# end of test.pl |
