File: verifier_strict.t

package info (click to toggle)
libmail-dkim-perl 0.54-1
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 1,412 kB
  • sloc: perl: 5,855; makefile: 10
file content (119 lines) | stat: -rw-r--r-- 3,127 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
#!/usr/bin/perl -I../lib

use strict;
use warnings;
use Test::More tests => 4;

use Mail::DKIM::Verifier;

my $homedir = ( -d "t" ) ? "t" : ".";

sub read_file {
    my $srcfile = shift;
    open my $fh, "<", $srcfile
      or die "Error: can't open $srcfile: $!\n";
    binmode $fh;
    local $/;
    my $content = <$fh>;
    close $fh;
    return $content;
}

sub test_email_strict {
    my ( $file, $expected_result ) = @_;
    print "# verifying message '$file'\n";
    my $dkim  = Mail::DKIM::Verifier->new( 'Strict' => 1 );
    my $path  = "$homedir/corpus/$file";
    my $email = read_file($path);
    $dkim->PRINT($email);
    $dkim->CLOSE;
    my $result = $dkim->result;
    print "#   result: " . $dkim->result_detail . "\n";
    ok( $result eq $expected_result, "'$file' should '$expected_result'" );
}

# Test strict mode
test_email_strict( "good_1878523.txt",  "invalid" );
test_email_strict( "good_ietf01_1.txt", "fail" );
test_email_strict( "good_qp_1.txt",     "invalid" );
test_email_strict( "mine_ietf01_3.txt", "pass" );

# override the DNS implementation, so that these tests do not
# rely on DNS servers I have no control over
my $CACHE;

sub Mail::DKIM::DNS::fake_query {
    my ( $domain, $type ) = @_;
    die "can't lookup $type record" if $type ne "TXT";

    unless ($CACHE) {
        open my $fh, "<", "$homedir/FAKE_DNS.dat"
          or die "Error: cannot read $homedir/FAKE_DNS.dat: $!\n";
        $CACHE = {};
        while (<$fh>) {
            chomp;
            next if /^\s*[#;]/ || /^\s*$/;
            my ( $k, $v ) = split /\s+/, $_, 2;
            $CACHE->{$k} =
                ( $v =~ /^~~(.*)~~$/ ) ? "$1"
              : $v eq "NXDOMAIN"       ? []
              :                          [ bless \$v, "FakeDNS::Record" ];
        }
        close $fh;
    }

    if ( not exists $CACHE->{$domain} ) {
        warn "did not cache that DNS entry: $domain\n";
        print STDERR ">>>\n";
        my @result = Mail::DKIM::DNS::orig_query( $domain, $type );
        if ( !@result ) {
            print STDERR "No results: $@\n";
        }
        else {
            foreach my $rr (@result) {

                # join with no intervening spaces, RFC 6376
                if ( Net::DNS->VERSION >= 0.69 ) {

                    # must call txtdata() in a list context
                    printf STDERR ( "%s\n", join( "", $rr->txtdata ) );
                }
                else {
                    # char_str_list method is 'historical'
                    printf STDERR ( "%s\n", join( "", $rr->char_str_list ) );
                }
            }
        }
        print STDERR "<<<\n";
        die;
    }

    if ( ref $CACHE->{$domain} ) {
        return @{ $CACHE->{$domain} };
    }
    else {
        die "DNS error: $CACHE->{$domain}\n";
    }
}

BEGIN {
    unless ( $ENV{use_real_dns} ) {
        *Mail::DKIM::DNS::orig_query = *Mail::DKIM::DNS::query;
        *Mail::DKIM::DNS::query      = *Mail::DKIM::DNS::fake_query;
    }
}

package FakeDNS::Record;

sub type {
    return "TXT";
}

sub char_str_list {
    return ${ $_[0] };
}

sub txtdata {
    return ${ $_[0] };
}