The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -I../blib/lib

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

use Mail::DKIM::DkPolicy;
use Mail::DKIM::DkimPolicy;
use Mail::DKIM::AuthorDomainPolicy;

my $policy;
$policy = Mail::DKIM::DkPolicy->new();
ok($policy, "new() works");

$policy = Mail::DKIM::DkPolicy->parse(String => "o=~; t=y");
ok($policy, "parse() works");

$policy = Mail::DKIM::DkPolicy->fetch(
		Protocol => "dns",
		Domain => "policy.test.authmilter.org");
ok($policy, "fetch() works (requires DNS)");
ok(!$policy->is_implied_default_policy, "not the default policy");

$policy = Mail::DKIM::DkPolicy->parse(String => "");
ok($policy, "parse() works (no tags)");

ok(!defined($policy->note), "note tag has default value");
$policy->note("hi there");
ok($policy->note eq "hi there", "note tag has been changed");

ok($policy->policy eq "~", "policy tag has default value");
$policy->policy("-");
ok($policy->policy eq "-", "policy tag has been changed");

ok(!$policy->testing, "testing flag has default value");
#$policy->testing(1);
#ok($policy->testing, "testing flag has been changed");

ok($policy->as_string, "as_string() method is implemented");

$policy = Mail::DKIM::DkPolicy->fetch(
		Protocol => "dns",
		Sender => 'alfred@doesnotexist.test.authmilter.org.invalid',
		);
ok($policy, "fetch() returns policy for nonexistent domain");
ok($policy->is_implied_default_policy, "yep, it's the default policy");

$policy = Mail::DKIM::AuthorDomainPolicy->fetch(
		Protocol => "dns",
		Domain => "nonexistent-subdomain.test.authmilter.org.invalid",
		);
ok($policy, "fetch() returns policy for nonexistent domain");
ok(!$policy->is_implied_default_policy, "shouldn't be the default policy");
ok($policy->policy eq "NXDOMAIN", "got policy of NXDOMAIN");

SKIP:
{
	skip "these tests fail when run on the other side of my firewall", 1
		unless ($ENV{DNS_TESTS} && $ENV{DNS_TESTS} > 1);

	$policy = eval { Mail::DKIM::AuthorDomainPolicy->fetch(
			Protocol => "dns",
			Domain => "blackhole.authmilter.org",
			) };
	my $E = $@;
        print "# got error: $E" if $E;
	ok(!$policy
		&& $E && $E =~ /(timeout|timed? out)/,
		"timeout error fetching policy");
}

SKIP:
{
	skip "test depends on specific DNS setup at test site", 1
		unless ($ENV{DNS_TESTS} && $ENV{DNS_TESTS} > 1);

        $policy = eval { Mail::DKIM::AuthorDomainPolicy->fetch(
		Protocol => "dns",
		Domain => "blackhole.authmilter.org",
		) };
    my $E = $@;
    print "# got error: $E" if $E;
    ok(!$policy
	&& $E && $E =~ /SERVFAIL/,
	"SERVFAIL dns error fetching policy");
}

# test a policy record where _domainkey.DOMAIN gives a
# DNS error, but DOMAIN itself is valid

SKIP: {
    skip "this test is currently failing",1 ;
    $policy = eval { Mail::DKIM::AuthorDomainPolicy->fetch(
    		Protocol => "dns",
    		Domain => "blackhole2.authmilter.org",
    		) };
    my $E = $@;
    print "# got error: $E" if $E;
    ok(!$policy
    	&& $E && $E =~ /SERVFAIL/,
    	"SERVFAIL dns error fetching policy");
}

#debug_policies(qw(yahoo.com hotmail.com gmail.com));
#debug_policies(qw(paypal.com ebay.com));
#debug_policies(qw(cisco.com sendmail.com));

sub debug_policies
{
	foreach my $domain (@_)
	{
		print "# $domain:\n";

		print "#  DomainKeys: ";
		my $policy = Mail::DKIM::DkPolicy->fetch(
			Protocol => "dns",
			Domain => $domain);
		if ($policy->is_implied_default_policy)
		{
			print "no policy\n";
		}
		else
		{
			print $policy->policy . " (";
			print $policy->as_string . ")\n";
		}

		print "#  DKIM: ";
		$policy = Mail::DKIM::DkimPolicy->fetch(
			Protocol => "dns",
			Domain => $domain);
		if ($policy->is_implied_default_policy)
		{
			print "no policy\n";
		}
		else
		{
			print $policy->policy . " (";
			print $policy->as_string . ")\n";
		}
	}
}