File Coverage

blib/lib/Mail/SPF/Record.pm

Criterion	Covered	Total	%
statement	30	136	22.0
branch	0	50	0.0
condition	0	4	0.0
subroutine	10	25	40.0
pod	8	13	61.5
total	48	228	21.0

#
# Mail::SPF::Record
# Abstract base class for SPF records.
#
# (C) 2005-2012 Julian Mehnle
#     2005      Shevek
# $Id: Record.pm 57 2012-01-30 08:15:31Z julian $
#
##############################################################################

package Mail::SPF::Record;

=head1 NAME

Mail::SPF::Record - Abstract base class for SPF records

=head1 VERSION

version 3.20250505

=cut

use warnings;
use strict;

use utf8;  # Hack to keep Perl 5.6 from whining about /[\p{}]/.

use base 'Mail::SPF::Base';

use overload
    '""'        => 'stringify',
    fallback    => 1;

use Error ':try';

use constant TRUE   => (0 == 0);
use constant FALSE  => not TRUE;

use constant default_qualifier      => '+';

use constant results_by_qualifier   => {
    ''  => 'pass',
    '+' => 'pass',
    '-' => 'fail',
    '~' => 'softfail',
    '?' => 'neutral'
};

# Interface:
##############################################################################

=head1 SYNOPSIS

=head2 Creating a record from a string

    use Mail::SPF::v1::Record;

    my $record = Mail::SPF::v1::Record->new_from_string("v=spf1 a mx -all");

=head2 Creating a record synthetically

    use Mail::SPF::v2::Record;

    my $record = Mail::SPF::v2::Record->new(
        scopes      => ['mfrom', 'pra'],
        terms       => [
            Mail::SPF::Mech::A->new(),
            Mail::SPF::Mech::MX->new(),
            Mail::SPF::Mech::All->new(qualifier => '-')
        ],
        global_mods => [
            Mail::SPF::Mod::Exp->new(domain_spec => 'spf-exp.example.com')
        ]
    );

=cut

# Implementation:
##############################################################################

=head1 DESCRIPTION

B is an abstract base class for SPF records.  It cannot be
instantiated directly.  Create an instance of a concrete sub-class instead.

=head2 Constructor

The following constructors are provided:

=over

=item B: returns I

Creates a new SPF record object.

%options is a list of key/value pairs representing any of the following
options:

=over

=item B

A I denoting the unparsed text of the record.

=item B

A reference to an I of Is denoting the scopes that are covered
by the record (see the description of the C option of
L constructor|Mail::SPF::Request/new>).

=item B

A reference to an I of I (i.e. I or
I) objects that make up the record.  I
objects must not be included here, but should be specified using the
C option instead.

=item B

A reference to an I of I objects that are global
modifiers of the record.

=back

=cut

sub new {
    my ($self, %options) = @_;
    $self->class ne __PACKAGE__
        or throw Mail::SPF::EAbstractClass;
    $self = $self->SUPER::new(%options);
    $self->{parse_text} = $self->{text} if not defined($self->{parse_text});
    $self->{terms}       ||= [];
    $self->{global_mods} ||= {};
    return $self;
}

=item B: returns I;
throws I, I,
I

Creates a new SPF record object by parsing the string and any options given.

=cut

sub new_from_string {
    my ($self, $text, %options) = @_;
    $self = $self->new(%options, text => $text);
    $self->parse();
    return $self;
}

=back

=head2 Class methods

The following class methods are provided:

=over

=item B: returns I

I.  Returns a regular expression that matches a legal version tag.

This method is abstract and must be implemented by sub-classes of
Mail::SPF::Record.

=item B: returns I

Returns the default qualifier, i.e. B<'+'>.

=item B: returns I of I

Returns a reference to a hash that maps qualifiers to result codes as follows:

     Qualifier | Result code
    -----------+-------------
         +     | pass
         -     | fail
         ~     | softfail
         ?     | neutral

=back

=head2 Instance methods

The following instance methods are provided:

=over

=cut

sub parse {
    my ($self) = @_;
    defined($self->{parse_text})
        or throw Mail::SPF::ENothingToParse('Nothing to parse for record');
    $self->parse_version_tag();
    $self->parse_term() while length($self->{parse_text});
    $self->parse_end();
    return;
}

sub parse_version_tag {
    my ($self) = @_;
    if (not $self->{parse_text} =~ s/^${\$self->version_tag_pattern}(?:\x20+|$)//) {
        throw Mail::SPF::EInvalidRecordVersion(
            "Not a '" . $self->version_tag . "' record: '" . $self->text . "'");
    }
}

sub parse_term {
    my ($self) = @_;

    eval {
      require Mail::SPF::Mech;
    };
    if($@) {
      throw Mail::SPF::ENothingToParse('Cannot load Mail::SPF::Mech class');
    }
    if (
        $self->{parse_text} =~ s/
            ^
            (
                ${\Mail::SPF::Mech->qualifier_pattern}?
               (${\Mail::SPF::Mech->name_pattern})
                [^\x20]*
            )
            (?: \x20+ | $ )
        //x
    ) {
        # Looks like a mechanism:
        my ($mech_text, $mech_name) = ($1, lc($2));
        my $mech_class = $self->mech_classes->{$mech_name};
        throw Mail::SPF::EInvalidMech("Unknown mechanism type '$mech_name' in '" . $self->version_tag . "' record")
            if not defined($mech_class);
        my $mech = $mech_class->new_from_string($mech_text);
        push(@{$self->{terms}}, $mech);
    }
    elsif (
        $self->{parse_text} =~ s/
            ^
            (
               (${\Mail::SPF::Mod->name_pattern}) =
                [^\x20]*
            )
            (?: \x20+ | $ )
        //x
    ) {
        # Looks like a modifier:
        my ($mod_text, $mod_name) = ($1, lc($2));
        my $mod_class = $self->mod_classes->{$mod_name};
        if (defined($mod_class)) {
            # Known modifier.
            my $mod = $mod_class->new_from_string($mod_text);
            if ($mod->isa('Mail::SPF::GlobalMod')) {
                # Global modifier.
                not defined($self->{global_mods}->{$mod_name}) or
                    throw Mail::SPF::EDuplicateGlobalMod("Duplicate global modifier '$mod_name' encountered");
                $self->{global_mods}->{$mod_name} = $mod;
            }
            elsif ($mod->isa('Mail::SPF::PositionalMod')) {
                # Positional modifier, queue normally:
                push(@{$self->{terms}}, $mod);
            }
            else {
                # Huh?  This should not happen.
            }
        }
        else {
            # Unknown modifier.
            my $mod = Mail::SPF::UnknownMod->new_from_string($mod_text);
            push(@{$self->{terms}}, $mod);
        }
    }
    else {
        throw Mail::SPF::EJunkInRecord("Junk encountered in record '" . $self->text . "'");
    }
    return;
}

sub parse_end {
    my ($self) = @_;
    throw Mail::SPF::EJunkInRecord("Junk encountered in record '" . $self->text . "'")
        if $self->{parse_text} ne '';
    delete($self->{parse_text});
    return;
}

=item B: returns I; throws I

Returns the unparsed text of the record.  Throws a I
exception if the record was created synthetically instead of being parsed, and
no text was provided.

=cut

sub text {
    my ($self) = @_;
    defined($self->{text})
        or throw Mail::SPF::ENoUnparsedText;
    return $self->{text};
}

=item B: returns I

I.  Returns the version tag of the record.

This method is abstract and must be implemented by sub-classes of
Mail::SPF::Record.

=item B: returns I of I

Returns a list of the scopes that are covered by the record.  See the
description of the L constructor's C option.

=cut

sub scopes {
    my ($self) = @_;
    return @{$self->{scopes}};
}

=item B: returns I of I

Returns a list of the terms that make up the record, excluding any global
modifiers, which are returned by the C method.  See the
description of the L constructor's C option.

=cut

sub terms {
    my ($self) = @_;
    return @{$self->{terms}};
}

=item B: returns I of I

Returns a list of the global modifiers of the record, ordered ascending by
modifier precedence.  See the description of the L constructor's
C option.

=cut

sub global_mods {
    my ($self) = @_;
    return sort { $a->precedence <=> $b->precedence } values(%{$self->{global_mods}});
}

=item B: returns I

Returns the global modifier of the given name if it is present in the record.
Returns B otherwise.  Use this method if you wish to retrieve a specific
global modifier as opposed to getting all of them.

=cut

sub global_mod {
    my ($self, $mod_name) = @_;
    return $self->{global_mods}->{$mod_name};
}

=item B: returns I

Returns the record's version tag and terms (including the global modifiers)
formatted as a string.  You can simply use a Mail::SPF::Record object as a
string for the same effect, see L<"OVERLOADING">.

=cut

sub stringify {
    my ($self) = @_;
    return join(' ', $self->version_tag, $self->terms, $self->global_mods);
}

=item B: throws I

Evaluates the SPF record in the context of the request parameters represented
by the given I object.  The given I
object is used for performing DNS look-ups.  Throws a I
object matching the outcome of the evaluation; see L.  See
RFC 4408, 4.6 and 4.7, for the exact algorithm used.

=cut

sub eval {
    my ($self, $server, $request) = @_;

    defined($server)
        or throw Mail::SPF::EOptionRequired('Mail::SPF server object required for record evaluation');
    defined($request)
        or throw Mail::SPF::EOptionRequired('Request object required for record evaluation');

    try {
        my @include_domains;
        my %inc_domain_cname;
        foreach my $term ($self->terms) {
            if ($term->isa('Mail::SPF::Mech')) {
                # Term is a mechanism.
                my $mech = $term;
                if($term->name eq "include") {
                  push(@include_domains, $term->{domain_spec}->{text});
                  if(scalar @include_domains > 1) {
                    foreach my $dom ( @include_domains ) {
                      my $packet;
                      if(not exists $inc_domain_cname{$dom}) {
                        $packet = $server->dns_lookup($dom, 'CNAME');
                        $inc_domain_cname{$dom} = $packet->{answer}[0]->{cname}->{name};
                      }
                      if(defined $inc_domain_cname{$dom}) {
                        if(grep /^$inc_domain_cname{$dom}$/, @include_domains) {
                          $server->throw_result('fail', $request,
                                      'referencing the same TXT record through multiple CNAME aliases is not permitted');
                        }
                      }
                    }
                  }
                }
                if ($mech->match($server, $request)) {
                    my $result_name  = $self->results_by_qualifier->{$mech->qualifier};
                    my $result_class = $server->result_class($result_name);
                    my $result = $result_class->new($server, $request, "Mechanism '$term' matched");
                    $mech->explain($server, $request, $result);
                    $result->throw();
                }
            }
            elsif ($term->isa('Mail::SPF::PositionalMod')) {
                # Term is a positional modifier.
                my $mod = $term;
                $mod->process($server, $request);
            }
            elsif ($term->isa('Mail::SPF::UnknownMod')) {
                # Term is an unknown modifier.  Ignore it (RFC 4408, 6/3).
            }
            else {
                # Invalid term object encountered:
                throw Mail::SPF::EUnexpectedTermObject(
                    "Unexpected term object '$term' encountered");
            }
        }
        undef @include_domains;
        undef %inc_domain_cname;

        # Default result when "falling off" the end of the record (RFC 4408, 4.7/1):
        $server->throw_result('neutral-by-default', $request,
            'Default neutral result due to no mechanism matches');
    }
    catch Mail::SPF::Result with {
        my ($result) = @_;

        # Process global modifiers in ascending order of precedence:
        foreach my $global_mod ($self->global_mods) {
            $global_mod->process($server, $request, $result);
        }

        $result->throw();
    };
}

=back

=head1 OVERLOADING

If a Mail::SPF::Record object is used as a I, the C method
is used to convert the object into a string.

=head1 SEE ALSO

L, L, L,
L, L, L

L

For availability, support, and license information, see the README file
included with Mail::SPF.

=head1 AUTHORS

Julian Mehnle , Shevek

=cut

TRUE;