File Coverage

Parser.yp

Criterion	Covered	Total	%
statement	91	97	93.8
branch	70	80	87.5
condition			n/a
subroutine	28	31	90.3
pod	4	4	100.0
total	193	212	91.0

%{#
# Validate::SPF::Parser source file
#
# Author: Anton Gerasimov
#

use Regexp::Common qw( net );

my $input;

my %errors = (
    E_DEFAULT               => "Just error",
    E_SYNTAX                => "Syntax error near token '%s'",
    E_INVALID_VERSION       => "Invalid SPF version",
    E_IPADDR_EXPECTED       => "Expected ip or network address",
    E_DOMAIN_EXPECTED       => "Expected domain name",
    E_UNEXPECTED_BITMASK    => "Unexpected bitmask",
    E_UNEXPECTED_IPADDR     => "Unexpected ip address",
    E_UNEXPECTED_DOMAIN     => "Unexpected domain name",
);

%}

%%

spf
    : chunks
        { $_[1] }
    ;

version
    : VERSION
        {
            $_[1] eq 'v=spf1' and
                return $_[0]->_ver_generic( $_[1] );

            $_[0]->raise_error( 'E_INVALID_VERSION', $_[1] );
        }
    ;

chunks
    : chunks chunk
        { push( @{$_[1]}, $_[2] ) if defined $_[2]; $_[1] }
    | chunk
        { defined $_[1] ? [ $_[1] ] : [ ] }
    ;

chunk
    : version
    | mechanism
    | modifier
    ;

mechanism
    : with_ipaddress
    | with_domain_bitmask
    | with_bitmask
    | with_domain
    ;

modifier
    : MODIFIER '=' DOMAIN
        {
            $_[0]->_mod_generic( $_[1], $_[3] );
        }
    ;

# ptr, exists, include, mx, a, all
with_domain
    : MECHANISM
        {
            $_[0]->raise_error( 'E_IPADDR_EXPECTED', $_[1] )
                if $_[1] =~ /ip[46]/i;
            $_[0]->raise_error( 'E_DOMAIN_EXPECTED', $_[1] )
                if $_[1] =~ /\A(exists|include)\Z/i;

            $_[0]->_mech_domain( '+', $_[1], $_[1] =~ /all/i ? undef : '@' );
        }
    | QUALIFIER MECHANISM
        {
            $_[0]->raise_error( 'E_IPADDR_EXPECTED', $_[1] . $_[2] )
                if $_[2] =~ /ip[46]/i;
            $_[0]->raise_error( 'E_DOMAIN_EXPECTED', $_[1] . $_[2] )
                if $_[2] =~ /\A(exists|include)\Z/i;

            $_[0]->_mech_domain( $_[1], $_[2], $_[2] =~ /all/i ? undef : '@' );
        }
    | MECHANISM ':' DOMAIN
        {
            my $ctx = $_[1] . ':' . $_[3];

            $_[0]->raise_error( 'E_UNEXPECTED_DOMAIN', $ctx )
                if $_[1] =~ /all/i;

            $_[0]->_mech_domain( '+', $_[1], $_[3] );
        }
    | QUALIFIER MECHANISM ':' DOMAIN
        {
            my $ctx = $_[1] . $_[2] . ':' . $_[4];

            $_[0]->raise_error( 'E_UNEXPECTED_DOMAIN', $ctx )
                if $_[2] =~ /all/i;

            $_[0]->_mech_domain( $_[1], $_[2], $_[4] );
        }
    ;

# mx, a
with_bitmask
    : MECHANISM '/' BITMASK
        {
            my $ctx = $_[1] . '/' . $_[3];

            $_[0]->raise_error( 'E_IPADDR_EXPECTED', $ctx )
                if $_[1] =~ /ip[46]/i;

            $_[0]->raise_error( 'E_UNEXPECTED_BITMASK', $ctx )
                if $_[1] =~ /\A(ptr|all|exists|include)\Z/i;

            $_[0]->_mech_domain_bitmask( '+', $_[1], '@', $_[3] );
        }
    | QUALIFIER MECHANISM '/' BITMASK
        {
            my $ctx = $_[1] . $_[2] . '/' . $_[4];

            $_[0]->raise_error( 'E_IPADDR_EXPECTED', $ctx )
                if $_[2] =~ /ip[46]/i;

            $_[0]->raise_error( 'E_UNEXPECTED_BITMASK', $ctx )
                if $_[2] =~ /\A(ptr|all|exists|include)\Z/i;

            $_[0]->_mech_domain_bitmask( $_[1], $_[2], '@', $_[4] );
        }
    ;

# mx, a
with_domain_bitmask
    : MECHANISM ':' DOMAIN '/' BITMASK
        {
            my $ctx = $_[1] . ':' . $_[3] . '/' . $_[5];

            $_[0]->raise_error( 'E_UNEXPECTED_BITMASK', $ctx )
                if $_[1] =~ /\A(ptr|all|exists|include)\Z/i;

            $_[0]->_mech_domain_bitmask( '+', $_[1], $_[3], $_[5] );
        }
    | QUALIFIER MECHANISM ':' DOMAIN '/' BITMASK
        {
            my $ctx = $_[1] . $_[2] . ':' . $_[4] . '/' . $_[6];

            $_[0]->raise_error( 'E_UNEXPECTED_BITMASK', $ctx )
                if $_[2] =~ /\A(ptr|all|exists|include)\Z/i;

            $_[0]->_mech_domain_bitmask( $_[1], $_[2], $_[4], $_[6] );
        }
    ;

# ip4, ip6
with_ipaddress
    : MECHANISM ':' IPADDRESS
        {
            my $ctx = $_[1] . ':' . $_[3];

            $_[0]->raise_error( 'E_UNEXPECTED_IPADDR', $ctx )
                if $_[1] =~ /\A(a|mx|ptr|all|exists|include)\Z/i;

            $_[0]->_mech_ipaddr_bitmask( '+', $_[1], $_[3], undef );
        }
    | QUALIFIER MECHANISM ':' IPADDRESS
        {
            my $ctx = $_[1] . $_[2] . ':' . $_[4];

            $_[0]->raise_error( 'E_UNEXPECTED_IPADDR', $ctx )
                if $_[2] =~ /\A(a|mx|ptr|all|exists|include)\Z/i;

            $_[0]->_mech_ipaddr_bitmask( $_[1], $_[2], $_[4], undef );
        }
    | MECHANISM ':' IPADDRESS '/' BITMASK
        {
            my $ctx = $_[1] . ':' . $_[3] . '/' . $_[5];

            $_[0]->raise_error( 'E_UNEXPECTED_IPADDR', $ctx )
                if $_[1] =~ /\A(a|mx|ptr|all|exists|include)\Z/i;

            $_[0]->_mech_ipaddr_bitmask( '+', $_[1], $_[3], $_[5] );
        }
    | QUALIFIER MECHANISM ':' IPADDRESS '/' BITMASK
        {
            my $ctx = $_[1] . $_[2] . ':' . $_[4] . '/' . $_[6];

            $_[0]->raise_error( 'E_UNEXPECTED_IPADDR', $ctx )
                if $_[2] =~ /\A(a|mx|ptr|all|exists|include)\Z/i;

            $_[0]->_mech_ipaddr_bitmask( $_[1], $_[2], $_[4], $_[6] );
        }
    ;

%%

sub parse {
    my ( $self, $text ) = @_;

    $input = $self->YYData->{INPUT} = $text;
    delete $self->YYData->{ERRMSG};

    return $self->YYParse( yylex => \&_lexer, yyerror => \&_error );
}

sub error {
    my ( $self ) = @_;
    return $self->YYData->{ERRMSG};
}

sub _build_error {
    my ( $self, $code, $context, @extra ) = @_;

    $code = 'E_DEFAULT'     unless exists $errors{$code};

    $self->YYData->{ERRMSG} = {
        text    => sprintf( $errors{$code} => @extra ),
        code    => $code,
        context => $context,
    };
}

sub raise_error {
    my ( $self, @params ) = @_;

    $self->_build_error( @params );
    $self->YYError;
}

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

    unless ( exists $self->YYData->{ERRMSG} ) {
        substr( $input, index( $input, $self->YYCurval ), 0, '<*>' );

        $self->_build_error( 'E_SYNTAX', $input, $self->YYCurval );
    }

    return;
}

sub _lexer {
    my ( $parser ) = @_;

    $parser->YYData->{INPUT} =~ s/^\s*//;

    for ( $parser->YYData->{INPUT} ) {
        # printf( "[debug] %s\n", $_ );

        s/^(v\=spf\d)\b//i
            and return ( 'VERSION', $1 );

        s/^(\/)\b//i
            and return ( '/', '/' );
        s/^(\:)\b//i
            and return ( ':', ':' );
        s/^(\=)\b//i
            and return ( '=', '=' );

        # qualifiers
        s/^([-~\+\?])\b//i
            and return ( 'QUALIFIER', $1 );

        # mechanisms
        s/^(all|ptr|a|mx|ip4|ip6|exists|include)\b//i
            and return ( 'MECHANISM', $1 );

        # modifiers
        s/^(redirect|exp)\b//i
            and return ( 'MODIFIER', $1 );

        s/^($RE{net}{IPv4}{dec}|$RE{net}{IPv6}{-sep=>':'})\b//i
            and return ( 'IPADDRESS', $1 );

        s/^([_\.a-z\d][\-a-z\d]*\.[\.\-a-z\d]*[a-z\d]?)\b//i
            and return ( 'DOMAIN', $1 );

        s/^(\d{1,3})\b//i
            and return ( 'BITMASK', $1 );

        # garbage
        s/^(.+)\b//i
            and return ( 'UNKNOWN', $1 );
    }

    # EOF
    return ( '', undef );
}

# generic modifier
sub _mod_generic {
    my ( $self, $mod, $domain ) = @_;

    return +{
        type => 'mod',
        modifier => lc $mod,
        (
            $domain
                ? ( domain => $domain ) :
                ( )
        ),
    };
}

# generic version
sub _ver_generic {
    my ( $self, $ver ) = @_;

    return +{
        type => 'ver',
        version => lc $ver,
    };
}


# generic mechanism
sub _mech_generic {
    my ( $self, $qualifier, $mech, $domain, $ipaddr, $bitmask ) = @_;

    return +{
        type => 'mech',
        qualifier => $qualifier,
        mechanism => lc $mech,
        (
            $domain
                ? ( domain => $domain ) :
                ( )
        ),
        (
            $ipaddr
                ? ( ( defined $bitmask ? 'network' : 'ipaddress' ) => $ipaddr )
                : ( )
        ),
        (
            defined $bitmask
                ? ( bitmask => $bitmask )
                : ( )
        ),
    };
}

sub _mech_domain {
    my ( $self, $qualifier, $mech, $domain ) = @_;

    return $self->_mech_generic( $qualifier, $mech, $domain, undef, undef );
}

sub _mech_domain_bitmask {
    my ( $self, $qualifier, $mech, $domain, $bitmask ) = @_;

    return $self->_mech_generic( $qualifier, $mech, $domain, undef, $bitmask );
}

sub _mech_ipaddr_bitmask {
    my ( $self, $qualifier, $mech, $ipaddr, $bitmask ) = @_;

    return $self->_mech_generic( $qualifier, $mech, undef, $ipaddr, $bitmask );
}