The Perl and Raku Conference 2025: Greenville, South Carolina - June 27-29 Learn more

use strict;
use lib 'lib';
use_ok('Mail::DMARC::Policy');
my $pol = Mail::DMARC::Policy->new();
isa_ok( $pol, 'Mail::DMARC::Policy' );
ok( !$pol->v, "policy, version, neg" );
ok( $pol->v('DMARC1'), "policy, set" );
cmp_ok( $pol->v, 'eq', 'DMARC1', "policy, version, pos" );
test_new();
test_is_valid_p();
test_is_valid_rf();
test_parse();
test_setter_values();
test_apply_defaults();
test_is_valid();
done_testing();
exit;
sub test_apply_defaults {
# empty policy
my $pol = Mail::DMARC::Policy->new();
isa_ok( $pol, 'Mail::DMARC::Policy' );
is_deeply( $pol, {}, "new, empty policy" );
# default policy
$pol = Mail::DMARC::Policy->new( v => 'DMARC1', p => 'reject' );
ok( $pol->apply_defaults(), "apply_defaults" );
is_deeply(
$pol,
{ v => 'DMARC1',
p => 'reject',
rf => 'afrf',
fo => 0,
adkim => 'r',
aspf => 'r',
ri => 86400
},
"new, with defaults"
);
}
sub test_setter_values {
my %good_vals = (
p => [qw/ none reject quarantine NONE REJEcT Quarantine /],
v => [qw/ DMARC1 dmarc1 /],
sp => [qw/ none reject quarantine NoNe REjEcT QuarAntine /],
adkim => [qw/ r s R S /],
aspf => [qw/ r s R S /],
fo => [qw/ 0 1 d s D S /],
rua => [
qw{ http://example.com/pub/dmarc!30m mailto:dmarc-feed@example.com!10m }
],
rf => [qw/ iodef afrf IODEF AFRF /],
ri => [ 0, 1, 1000, 4294967295 ],
pct => [ 0, 10, 50, 99, 100 ],
);
foreach my $k ( keys %good_vals ) {
foreach my $t ( @{ $good_vals{$k} } ) {
ok( defined $pol->$k($t), "$k, $t" );
}
}
my %bad_vals = (
p => [qw/ nonense silly example /],
v => ['DMARC2'],
sp => [qw/ nones rejection quarrantine /],
adkim => [qw/ relaxed strict /],
aspf => [qw/ relaxed strict /],
fo => [qw/ 00 11 dd ss /],
ruf => [qw{ mail:msimerson@cnap.org }],
rf => [qw/ iodef2 rfrf2 rfrf /],
ri => [ -1, 'a', 4294967296 ],
pct => [ -1, 'f', 101, 1.1, '1.0', '5.f1' ],
);
foreach my $k ( keys %bad_vals ) {
foreach my $t ( @{ $bad_vals{$k} } ) {
eval { $pol->$k($t); };
ok( $@, "neg, $k, $t" );
}
}
}
sub test_new {
# empty policy
my $pol = Mail::DMARC::Policy->new();
isa_ok( $pol, 'Mail::DMARC::Policy' );
is_deeply( $pol, {}, "new, empty policy" );
# default policy
$pol = Mail::DMARC::Policy->new(
v => 'DMARC1',
p => 'reject',
pct => 90,
rua => 'mailto:u@d.co'
);
isa_ok( $pol, 'Mail::DMARC::Policy' );
is_deeply(
$pol,
{ v => 'DMARC1', p => 'reject', pct => 90, rua => 'mailto:u@d.co' },
"new, with args"
);
# text record
$pol = Mail::DMARC::Policy->new(
'v=DMARC1; p=reject; rua=mailto:u@d.co; pct=90');
isa_ok( $pol, 'Mail::DMARC::Policy' );
is_deeply(
$pol,
{ v => 'DMARC1', p => 'reject', pct => 90, rua => 'mailto:u@d.co' },
"new, with args"
);
}
sub test_parse {
$pol = $pol->parse(
'v=DMARC1; p=reject; rua=mailto:dmarc@example.co; pct=90');
isa_ok( $pol, 'Mail::DMARC::Policy' );
is_deeply(
$pol,
{ v => 'DMARC1',
p => 'reject',
pct => 90,
rua => 'mailto:dmarc@example.co',
},
'parse'
);
}
sub test_is_valid_p {
foreach my $p (qw/ none reject quarantine /) {
ok( $pol->is_valid_p($p), "policy->is_valid_p, pos, $p" );
}
foreach my $p (qw/ other gibberish non-policy words /) {
ok( !$pol->is_valid_p($p), "policy->is_valid_p, neg, $p" );
}
}
sub test_is_valid_rf {
foreach my $f (qw/ afrf iodef /) {
ok( $pol->is_valid_rf($f), "policy->is_valid_rf, pos, $f" );
}
foreach my $f (qw/ ffrf i0def report /) {
ok( !$pol->is_valid_rf($f), "policy->is_valid_rf, neg, $f" );
}
}
sub test_is_valid {
# empty policy
my $pol = Mail::DMARC::Policy->new();
eval { $pol->is_valid(); };
chomp $@;
ok( $@, "is_valid, $@" );
eval { $pol = Mail::DMARC::Policy->new('v=DMARC1') };
chomp $@;
ok( $@, "is_valid, 1.4.1 meaningless, $@" );
eval { $pol = Mail::DMARC::Policy->new('v=DMARC1\; p=reject\;') };
ok( $pol, "is_valid, 1.4.3 extra backslashes" );
eval { $pol = Mail::DMARC::Policy->new('v=DMARC1; p=reject; newtag=unknown') };
ok( $pol, "is_valid, 1.4.4 unknown tag" );
eval { $pol = Mail::DMARC::Policy->new('v=DMARC1; p=bogus') };
chomp $@;
ok( $@, "is_valid, 1.4.5 bogus p value, $@" );
eval { $pol = Mail::DMARC::Policy->new('v=DMARC1; p=reject; rua=a@dmarc-qa.com;') };
ok( $pol, "is_valid, 1.4.6 missing mailto" );
# policy, minimum
$pol = Mail::DMARC::Policy->new( 'v=DMARC1; p=reject' );
ok( $pol->is_valid, "is_valid, 1.4.2 smallest record" );
# policy, min + defaults
$pol->apply_defaults();
ok( $pol->is_valid, "is_valid, pos, w/defaults" );
# 9.6 policy discovery
$pol = undef;
eval { $pol = Mail::DMARC::Policy->new( v => 'DMARC1' ); }; # or diag $@;
ok( !$pol, "is_valid, neg, missing p, no rua" );
eval {
$pol = Mail::DMARC::Policy->new(
v => 'DMARC1',
);
}; # or diag $@;
ok( !$pol, "is_valid, neg, missing p, invalid rua" );
$pol = undef;
eval {
$pol = Mail::DMARC::Policy->new(
v => 'DMARC1',
rua => 'mailto:test@example.com'
);
};
ok( $pol && $pol->is_valid, "is_valid, pos, implicit p=none w/rua" );
}