File Coverage

blib/lib/Mail/DKIM/DkPolicy.pm

Criterion	Covered	Total	%
statement	41	63	65.0
branch	11	28	39.2
condition	4	21	19.0
subroutine	12	16	75.0
pod	10	12	83.3
total	78	140	55.7

package Mail::DKIM::DkPolicy;
use strict;
use warnings;
our $VERSION = '1.20230630'; # VERSION
# ABSTRACT: represents a DomainKeys Sender Signing Policy record

# Copyright 2005-2009 Messiah College.
# Jason Long

# Copyright (c) 2004 Anthony D. Urso. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

use base 'Mail::DKIM::Policy';
use Mail::DKIM::DNS;


# get_lookup_name() - determine name of record to fetch
#
sub get_lookup_name {
    my $self = shift;
    my ($prms) = @_;

    # in DomainKeys, the record to fetch is determined based on the
    # Sender header, then the From header

    if ( $prms->{Author} && !$prms->{Sender} ) {
        $prms->{Sender} = $prms->{Author};
    }
    if ( $prms->{Sender} && !$prms->{Domain} ) {

        # pick domain from email address
        $prms->{Domain} = ( $prms->{Sender} =~ /\@([^@]*)$/ and $1 );
    }

    unless ( $prms->{Domain} ) {
        die "no domain to fetch policy for\n";
    }

    # IETF seems poised to create policy records this way
    #my $host = '_policy._domainkey.' . $prms{Domain};

    # but Yahoo! policy records are still much more common
    # see historic RFC4870, section 3.6
    return '_domainkey.' . $prms->{Domain};
}


sub new {
    my $class = shift;
    return $class->parse( String => 'o=~' );
}


#undocumented private class method
our $DEFAULT_POLICY;

sub default {
    my $class = shift;
    $DEFAULT_POLICY ||= $class->new;
    return $DEFAULT_POLICY;
}


sub apply {
    my $self = shift;
    my ($dkim) = @_;

    my $first_party;
    foreach my $signature ( $dkim->signatures ) {
        next if $signature->result ne 'pass';

        my $oa = $dkim->message_sender->address;
        if ( $signature->identity_matches($oa) ) {

            # found a first party signature
            $first_party = 1;
            last;
        }
    }

    return 'accept' if $first_party;
    return 'reject' if ( $self->signall && !$self->testing );
    return 'neutral';
}


sub flags {
    my $self = shift;

    (@_)
      and $self->{tags}->{t} = shift;

    $self->{tags}->{t};
}


sub is_implied_default_policy {
    my $self           = shift;
    my $default_policy = ref($self)->default;
    return ( $self == $default_policy );
}


sub name {
    return 'sender';
}


sub note {
    my $self = shift;

    (@_)
      and $self->{tags}->{n} = shift;

    $self->{tags}->{n};
}


sub policy {
    my $self = shift;

    (@_)
      and $self->{tags}->{o} = shift;

    if ( defined $self->{tags}->{o} ) {
        return $self->{tags}->{o};
    }
    else {
        return '~';    # the default
    }
}


sub signall {
    my $self = shift;
    return ( $self->policy && $self->policy eq '-' );
}

sub signsome {
    my $self = shift;

    $self->policy
      or return 1;

    $self->policy eq '~'
      and return 1;

    return;
}


sub testing {
    my $self = shift;
    my $t    = $self->flags;
    ( $t && $t =~ /y/i )
      and return 1;
    return;
}

1;

__END__