File Coverage

blib/lib/Mail/SPF/Term.pm

Criterion	Covered	Total	%
statement	102	158	64.5
branch	0	28	0.0
condition	0	15	0.0
subroutine	22	32	68.7
pod	1	10	10.0
total	125	243	51.4

#
# Mail::SPF::Term
# SPF record term class.
#
# (C) 2005-2012 Julian Mehnle
#     2005      Shevek
# $Id: Term.pm 57 2012-01-30 08:15:31Z julian $
#
##############################################################################

package Mail::SPF::Term;

=head1 NAME

Mail::SPF::Term - SPF record term class

=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 NetAddr::IP;

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

use constant name_pattern               => qr/ \p{IsAlpha} [\p{IsAlnum}\-_.]* /x;

use constant macro_literal_pattern      => qr/[!-\$&-~]/;
use constant macro_delimiter            => qr/[.\-+,\/_=]/;
use constant macro_transformers_pattern => qr/\d*r?/;
use constant macro_expand_pattern       => qr/
    \%
    (?:
        { \p{IsAlpha} ${\macro_transformers_pattern} ${\macro_delimiter}* } |
        [%_-]
    )
/x;

use constant macro_string_pattern       => qr/
    (?:
        ${\macro_expand_pattern}  |
        ${\macro_literal_pattern}
    )*
/x;

use constant toplabel_pattern           => qr/
    \p{IsAlnum}+ - [\p{IsAlnum}-]* \p{IsAlnum}  |
    \p{IsAlnum}*    \p{IsAlpha}    \p{IsAlnum}*
/x;

use constant domain_end_pattern         => qr/
    \. ${\toplabel_pattern} \.? |
    ${\macro_expand_pattern}
/x;

use constant domain_spec_pattern        => qr/ ${\macro_string_pattern} ${\domain_end_pattern} /x;

use constant qnum_pattern               => qr/ 25[0-5] | 2[0-4]\d | 1\d\d | [1-9]\d | \d /x;
use constant ipv4_address_pattern       => qr/ ${\qnum_pattern} (?: \. ${\qnum_pattern} ){3} /x;

use constant hexword_pattern            => qr/\p{IsXDigit}{1,4}/;
use constant two_hexwords_or_ipv4_address_pattern => qr/
    ${\hexword_pattern} : ${\hexword_pattern} | ${\ipv4_address_pattern}
/x;
use constant ipv6_address_pattern       => qr/
    #                x:x:x:x:x:x:x:x |     x:x:x:x:x:x:n.n.n.n
    (?: ${\hexword_pattern} : ){6}                                    ${\two_hexwords_or_ipv4_address_pattern} |
    #                 x::x:x:x:x:x:x |      x::x:x:x:x:n.n.n.n
    (?: ${\hexword_pattern} : ){1}   : (?: ${\hexword_pattern} : ){4} ${\two_hexwords_or_ipv4_address_pattern} |
    #               x[:x]::x:x:x:x:x |    x[:x]::x:x:x:n.n.n.n
    (?: ${\hexword_pattern} : ){1,2} : (?: ${\hexword_pattern} : ){3} ${\two_hexwords_or_ipv4_address_pattern} |
    #               x[:...]::x:x:x:x |    x[:...]::x:x:n.n.n.n
    (?: ${\hexword_pattern} : ){1,3} : (?: ${\hexword_pattern} : ){2} ${\two_hexwords_or_ipv4_address_pattern} |
    #                 x[:...]::x:x:x |      x[:...]::x:n.n.n.n
    (?: ${\hexword_pattern} : ){1,4} : (?: ${\hexword_pattern} : ){1} ${\two_hexwords_or_ipv4_address_pattern} |
    #                   x[:...]::x:x |        x[:...]::n.n.n.n
    (?: ${\hexword_pattern} : ){1,5} :                                ${\two_hexwords_or_ipv4_address_pattern} |
    #                     x[:...]::x |                       -
    (?: ${\hexword_pattern} : ){1,6} :     ${\hexword_pattern}                                                 |
    #                      x[:...]:: |                       -
    (?: ${\hexword_pattern} : ){1,7} :                                                                         |
    #                      ::[...:]x |                       -
 :: (?: ${\hexword_pattern} : ){0,6}       ${\hexword_pattern}                                                 |
    #                              - |         ::[...:]n.n.n.n
 :: (?: ${\hexword_pattern} : ){0,5}                                  ${\two_hexwords_or_ipv4_address_pattern} |
    #                             :: |                       -
 ::
/x;

=head1 DESCRIPTION

An object of class B represents a term within an SPF record.
Mail::SPF::Term cannot be instantiated directly.  Create an instance of a
concrete sub-class instead.

=head2 Constructor

The following constructor is provided:

=over

=item B: returns I

I.  Creates a new SPF record term object.

%options is a list of key/value pairs, however Mail::SPF::Term itself specifies
no constructor options.

=item B: returns I;
throws I, I

I.  Creates a new SPF record term 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

Returns a regular expression that matches any legal name for an SPF record
term.

=back

=head2 Instance methods

The following instance methods are provided:

=over

=cut

sub parse_domain_spec {
    my ($self, $required) = @_;
    if ($self->{parse_text} =~ s/^(${\$self->domain_spec_pattern})//) {
        my $domain_spec = $1;
        $domain_spec =~ s/^(.*?)\.?$/\L$1/;
        $self->{domain_spec} = Mail::SPF::MacroString->new(text => $domain_spec);
    }
    elsif ($required) {
        throw Mail::SPF::ETermDomainSpecExpected(
            "Missing required domain-spec in '" . $self->text . "'");
    }
    return;
}

sub parse_ipv4_address {
    my ($self, $required) = @_;
    if ($self->{parse_text} =~ s/^(${\$self->ipv4_address_pattern})//) {
        $self->{ip_address} = $1;
    }
    elsif ($required) {
        throw Mail::SPF::ETermIPv4AddressExpected(
            "Missing required IPv4 address in '" . $self->text . "'");
    }
    return;
}

sub parse_ipv4_prefix_length {
    my ($self, $required) = @_;
    if ($self->{parse_text} =~ s#^/(\d+)##) {
        $1 >= 0 and $1 <= 32 and $1 !~ /^0./
            or throw Mail::SPF::ETermIPv4PrefixLengthExpected(
                    "Invalid IPv4 prefix length encountered in '" . $self->text . "'");
        $self->{ipv4_prefix_length} = $1;
    }
    elsif (not $required) {
        $self->{ipv4_prefix_length} = $self->default_ipv4_prefix_length;
    }
    else {
        throw Mail::SPF::ETermIPv4PrefixLengthExpected(
            "Missing required IPv4 prefix length in '" . $self->text . "'");
    }
    return;
}

sub parse_ipv4_network {
    my ($self, $required) = @_;
    $self->parse_ipv4_address($required);
    $self->parse_ipv4_prefix_length();
    $self->{ip_network} = NetAddr::IP->new($self->{ip_address}, $self->{ipv4_prefix_length});
    return;
}

sub parse_ipv6_address {
    my ($self, $required) = @_;
    if ($self->{parse_text} =~ s/^(${\$self->ipv6_address_pattern})(?=\/|$)//) {
        $self->{ip_address} = $1;
    }
    elsif ($required) {
        throw Mail::SPF::ETermIPv6AddressExpected(
            "Missing required IPv6 address in '" . $self->text . "'");
    }
    return;
}

sub parse_ipv6_prefix_length {
    my ($self, $required) = @_;
    if ($self->{parse_text} =~ s#^/(\d+)##) {
        $1 >= 0 and $1 <= 128 and $1 !~ /^0./
            or throw Mail::SPF::ETermIPv6PrefixLengthExpected(
                    "Invalid IPv6 prefix length encountered in '" . $self->text . "'");
        $self->{ipv6_prefix_length} = $1;
    }
    elsif (not $required) {
        $self->{ipv6_prefix_length} = $self->default_ipv6_prefix_length;
    }
    else {
        throw Mail::SPF::ETermIPv6PrefixLengthExpected(
            "Missing required IPv6 prefix length in '" . $self->text . "'");
    }
    return;
}

sub parse_ipv6_network {
    my ($self, $required) = @_;
    $self->parse_ipv6_address($required);
    $self->parse_ipv6_prefix_length();
    $self->{ip_network} = NetAddr::IP->new(
        $self->{ip_address}, $self->{ipv6_prefix_length});
    return;
}

sub parse_ipv4_ipv6_prefix_lengths {
    my ($self) = @_;
    $self->parse_ipv4_prefix_length();
    if (
        defined($self->{ipv4_prefix_length}) and  # an IPv4 prefix length has been parsed, and
        $self->{parse_text} =~ s#^/##             # another slash is following
    ) {
        # Parse an IPv6 prefix length:
        $self->parse_ipv6_prefix_length(TRUE);
    }
    return;
}

=item B: returns I; throws I

Returns the unparsed text of the term.  Throws a I
exception if the term 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 name of the term.

=back

=head1 SEE ALSO

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;