File Coverage

blib/lib/Mail/DKIM/Policy.pm

Criterion	Covered	Total	%
statement	50	71	70.4
branch	7	22	31.8
condition	1	5	20.0
subroutine	9	12	75.0
pod	4	7	57.1
total	71	117	60.6

package Mail::DKIM::Policy;
use strict;
use warnings;
our $VERSION = '1.20230911'; # VERSION
# ABSTRACT: abstract base class for originator "signing" policies

# Copyright 2005-2007 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 Mail::DKIM::DNS;


sub fetch {
    my $class  = shift;
    my $waiter = $class->fetch_async(@_);
    return $waiter->();
}

sub fetch_async {
    my $class = shift;
    my %prms  = @_;

    ( $prms{'Protocol'} eq 'dns' )
      or die "invalid protocol '$prms{Protocol}'\n";

    my $host       = $class->get_lookup_name( \%prms );
    my %callbacks  = %{ $prms{Callbacks} || {} };
    my $on_success = $callbacks{Success} || sub { $_[0] };
    $callbacks{Success} = sub {
        my @resp = @_;
        unless (@resp) {

            # no requested resource records or NXDOMAIN,
            # use default policy
            return $on_success->( $class->default );
        }

        my $strn;
        foreach my $rr (@resp) {
            next unless $rr->type eq 'TXT';

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

                # must call txtdata() in a list context
                $strn = join '', $rr->txtdata;
            }
            else {
                # char_str_list method is 'historical'
                $strn = join '', $rr->char_str_list;
            }
        }

        unless ($strn) {

            # empty record found in DNS, use default policy
            return $on_success->( $class->default );
        }

        my $self = $class->parse(
            String => $strn,
            Domain => $prms{Domain},
        );
        return $on_success->($self);
    };

    #
    # perform DNS query for domain policy...
    #
    my $waiter =
      Mail::DKIM::DNS::query_async( $host, 'TXT', Callbacks => \%callbacks, );
    return $waiter;
}

sub parse {
    my $class = shift;
    my %prms  = @_;

    my $text = $prms{'String'};
    my %tags;
    foreach my $tag ( split /;/, $text ) {

        # strip whitespace
        $tag =~ s/^\s+|\s+$//g;

        my ( $tagname, $value ) = split /=/, $tag, 2;
        unless ( defined $value ) {
            die "policy syntax error\n";
        }

        $tagname =~ s/\s+$//;
        $value =~ s/^\s+//;
        $tags{$tagname} = $value;
    }

    $prms{tags} = \%tags;
    return bless \%prms, $class;
}


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 as_string {
    my $self = shift;

    return join(
        '; ', map { "$_=" . $self->{tags}->{$_} }
          keys %{ $self->{tags} }
    );
}


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


sub location {
    my $self = shift;
    return $self->{Domain};
}


1;

__END__