Mail::SPF::MacroString - SPF record macro string class

Mail-SPF documentation Contained in the Mail-SPF distribution.

Index

Code Index:

NAME

Top

Mail::SPF::MacroString - SPF record macro string class

SYNOPSIS

Top

Providing the expansion context early

    use Mail::SPF::MacroString;

    my $macrostring = Mail::SPF::MacroString->new(
        text    => '%{ir}.%{v}._spf.%{d2}',
        server  => $server,
        request => $request
    );

    my $expanded = $macrostring->expand;

Providing the expansion context late

    use Mail::SPF::MacroString;

    my $macrostring = Mail::SPF::MacroString->new(
        text    => '%{ir}.%{v}._spf.%{d2}'
    );

    my $expanded1 = $macrostring->expand($server, $request1);

    $macrostring->context($server, $request2);
    my $expanded2 = $macrostring->expand;

DESCRIPTION

Top

An object of class Mail::SPF::MacroString represents a macro string that can be expanded to a plain string in the context of an SPF request.

Constructor

The following constructor is provided:

new(%options): returns Mail::SPF::MacroString

Creates a new SPF record macro string object.

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

text

Required. The unexpanded text of the new macro string.

server

The Mail::SPF::Server object that is to be used when expanding the macro string. A server object need not be attached statically to the macro string; it can be specified dynamically when calling the expand method.

request

The Mail::SPF::Request object that is to be used when expanding the macro string. A request object need not be attached statically to the macro string; it can be specified dynamically when calling the expand method.

is_explanation

A boolean denoting whether the macro string is an explanation string obtained via an exp modifier. If true, the c, r, and t macros may appear in the macro string, otherwise they may not, and if they do, a Mail::SPF::EInvalidMacro exception will be thrown when the macro string is expanded. Defaults to false.

Instance methods

The following instance methods are provided:

text: returns string

Returns the unexpanded text of the macro string.

context($server, $request): throws Mail::SPF::EOptionRequired

Attaches the given Mail::SPF::Server and Mail::SPF::Request objects as the context for the macro string.

expand: returns string; throws Mail::SPF::EMacroExpansionCtxRequired, Mail::SPF::EInvalidMacroString, Mail::SPF::Result::PermError
expand($server, $request): returns string; throws Mail::SPF::EMacroExpansionCtxRequired, Mail::SPF::EInvalidMacroString, Mail::SPF::Result::PermError

Expands the text of the macro string using either the context specified through an earlier call to the context() method, or the given context, and returns the resulting string. See RFC 4408, 8, for how macros are expanded.

is_explanation: returns boolean

Returns true if the macro string is an explanation string obtained via an exp modifier. See the description of the new constructor's is_explanation option.

stringify: returns string

Returns the expanded text of the macro string if a context is attached to the object. Returns the unexpanded text otherwise. You can simply use a Mail::SPF::MacroString object as a string for the same effect, see "OVERLOADING".

OVERLOADING

Top

If a Mail::SPF::MacroString object is used as a string, the stringify method is used to convert the object into a string.

SEE ALSO

Top

Mail::SPF, Mail::SPF::Record, Mail::SPF::Server, Mail::SPF::Request

http://www.ietf.org/rfc/rfc4408.txt

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

AUTHORS

Top

Julian Mehnle <julian@mehnle.net>, Shevek <cpan@anarres.org>

Mail-SPF documentation Contained in the Mail-SPF distribution. 
#
# Mail::SPF::MacroString
# SPF record macro string class.
#
# (C) 2005-2009 Julian Mehnle <julian@mehnle.net>
#     2005      Shevek <cpan@anarres.org>
# $Id: MacroString.pm 53 2009-10-31 21:40:08Z Julian Mehnle $
#
##############################################################################

package Mail::SPF::MacroString;


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 URI::Escape ();

use Mail::SPF::Util;

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

use constant default_split_delimiters   => '.';
use constant default_join_delimiter     => '.';

use constant uri_unreserved_chars   => 'A-Za-z0-9\-._~';
    # "unreserved" characters according to RFC 3986 -- not the "uric" chars!
    # This deliberately deviates from what RFC 4408 says.  This is a bug in
    # RFC 4408.

use constant macos_epoch_offset     => ((1970 - 1904) * 365 + 17) * 24 * 3600;
    # This is a hack because the MacOS Classic epoch is relative to the local
    # timezone.  Get a real OS!

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


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


sub new {
    my ($self, %options) = @_;
    $self = $self->SUPER::new(%options);
    defined($self->{text})
        or throw Mail::SPF::EOptionRequired("Missing required 'text' option");
    return $self;
}


# Read-only accessor:
__PACKAGE__->make_accessor('text', TRUE);


sub context {
    my ($self, $server, $request) = @_;
    $self->_is_valid_context(TRUE, $server, $request);
    $self->{server}   = $server;
    $self->{request}  = $request;
    $self->{expanded} = undef;
    return;
}


sub expand {
    my ($self, @context) = @_;
    
    return $self->{expanded}
        if defined($self->{expanded});
    
    my $text = $self->{text};
    return undef
        if not defined($text);
    
    return $self->{expanded} = $text
        if $text !~ /%/;  # Short-circuit expansion if text has no '%' character.

    my ($server, $request) = @context ? @context : ($self->{server}, $self->{request});
    $self->_is_valid_context(TRUE, $server, $request);
    
    my $expanded = '';
    pos($text) = 0;
    
    while ($text =~ m/ \G (.*?) %(.) /cgx) {
        $expanded .= $1;
        my $key = $2;
        my $pos = pos($text) - 2;
        
        if ($key eq '{') {
            if ($text =~ m/ \G (\w|_\p{IsAlpha}+) ([0-9]+)? (r)? ([.\-+,\/_=]*)? } /cgx) {
                my ($char, $rh_parts, $reverse, $delimiters) = ($1, $2, $3, $4);
                
                # Upper-case macro chars trigger URL-escaping AKA percent-encoding
                # (RFC 4408, 8.1/26):
                my $do_percent_encode = $char =~ tr/A-Z/a-z/;
                
                my $value;
                
                if    ($char eq 's') {  # RFC 4408, 8.1/19
                    $value = $request->identity;
                }
                elsif ($char eq 'l') {  # RFC 4408, 8.1/19
                    $value = $request->localpart;
                }
                elsif ($char eq 'o') {  # RFC 4408, 8.1/19
                    $value = $request->domain;
                }
                elsif ($char eq 'd') {  # RFC 4408, 8.1/6/4
                    $value = $request->authority_domain;
                }
                elsif ($char eq 'i') {  # RFC 4408, 8.1/20, 8.1/21
                    my $ip_address = $request->ip_address;
                    $ip_address = Mail::SPF::Util->ipv6_address_to_ipv4($ip_address)
                        if Mail::SPF::Util->ipv6_address_is_ipv4_mapped($ip_address);
                    my $ip_address_version = $ip_address->version;
                    if ($ip_address_version == 4) {
                        $value = $ip_address->addr;
                    }
                    elsif ($ip_address_version == 6) {
                        $value = join(".", split(//, unpack("H32", $ip_address->aton)));
                    }
                    else {
                        # Unexpected IP address version.
                        $server->throw_result('permerror', $request,
                            "Unexpected IP address version '$ip_address_version' in request");
                    }
                }
                elsif ($char eq 'p') {  # RFC 4408, 8.1/22
                    try {
                        $value = Mail::SPF::Util->valid_domain_for_ip_address(
                            $server, $request, $request->ip_address, $request->authority_domain,
                            TRUE, TRUE
                        );
                    }
                    catch Mail::SPF::EDNSError with {};
                    $value ||= 'unknown';
                }
                elsif ($char eq 'v') {  # RFC 4408, 8.1/6/7
                    my $ip_address_version = $request->ip_address->version;
                    if ($ip_address_version == 4) {
                        $value = 'in-addr';
                    }
                    elsif ($ip_address_version == 6) {
                        $value = 'ip6';
                    }
                    else {
                        # Unexpected IP address version.
                        $server->throw_result('permerror', $request,
                            "Unexpected IP address version '$ip_address_version' in request");
                    }
                }
                elsif ($char eq 'h') {  # RFC 4408, 8.1/6/8
                    $value = $request->helo_identity || 'unknown';
                }
                elsif ($char eq 'c') {  # RFC 4408, 8.1/20, 8.1/21
                    $self->{is_explanation}
                        or throw Mail::SPF::EInvalidMacro(
                                "Illegal 'c' macro in non-explanation macro string '$text'");
                    my $ip_address = $request->ip_address;
                    $ip_address = Mail::SPF::Util->ipv6_address_to_ipv4($ip_address)
                        if Mail::SPF::Util->ipv6_address_is_ipv4_mapped($ip_address);
                    $value = Mail::SPF::Util->ip_address_to_string($ip_address);
                }
                elsif ($char eq 'r') {  # RFC 4408, 8.1/23
                    $self->{is_explanation}
                        or throw Mail::SPF::EInvalidMacro(
                                "Illegal 'r' macro in non-explanation macro string '$text'");
                    $value = $server->hostname || 'unknown';
                }
                elsif ($char eq 't') {  # RFC 4408, 8.1/24
                    $self->{is_explanation}
                        or throw Mail::SPF::EInvalidMacro(
                                "Illegal 't' macro in non-explanation macro string '$text'");
                    $value = $^O ne 'MacOS' ? time() : time() + $self->macos_epoch_offset;
                }
                elsif ($char eq '_scope') {
                    # Scope pseudo macro for internal use only!
                    $value = $request->scope;
                }
                else {
                    # Unknown macro character.
                    throw Mail::SPF::EInvalidMacro(
                        "Unknown macro character '$char' at pos $pos in macro string '$text'");
                }
                
                if (defined($rh_parts) or defined($reverse)) {
                    $delimiters ||= $self->default_split_delimiters;
                    my @list = split(/[\Q$delimiters\E]/, $value);
                    @list = reverse(@list) if defined($reverse);
                    
                    # Extract desired parts:
                    if (defined($rh_parts) and $rh_parts > 0) {
                        splice(@list, 0, @list >= $rh_parts ? @list - $rh_parts : 0);
                    }
                    if (defined($rh_parts) and $rh_parts == 0) {
                        throw Mail::SPF::EInvalidMacro(
                            "Illegal selection of 0 (zero) right-hand parts at pos $pos in macro string '$text'");
                    }
                    
                    $value = join($self->default_join_delimiter, @list);
                }

                $value = URI::Escape::uri_escape($value, '^' . $self->uri_unreserved_chars)
                    # Note the comment about the set of safe/unsafe characters at the
                    # definition of the "uri_unreserved_chars" constant above.
                    if $do_percent_encode;
                
                $expanded .= $value;
            }
            else {
                # Invalid macro expression.
                throw Mail::SPF::EInvalidMacro(
                    "Invalid macro expression at pos $pos in macro string '$text'");
            }
        }
        elsif ($key eq '-') {
            $expanded .= '%20';
        }
        elsif ($key eq '_') {
            $expanded .= ' ';
        }
        elsif ($key eq '%') {
            $expanded .= '%';
        }
        else {
            # Invalid macro expression.
            throw Mail::SPF::EInvalidMacro(
                "Invalid macro expression at pos $pos in macro string '$text'");
        }
    }
    
    $expanded .= substr($text, pos($text));  # Append remaining unmatched characters.
    
    #print("DEBUG: Expand $text -> $expanded\n");
    #printf("DEBUG:   Caller: %s() (line %d)\n", (caller(1))[3, 2]);
    return @context ? $expanded : ($self->{expanded} = $expanded);
}


# Make read-only accessor:
__PACKAGE__->make_accessor('is_explanation', TRUE);


sub stringify {
    my ($self) = @_;
    return
        $self->_is_valid_context(FALSE, $self->{server}, $self->{request}) ?
            $self->expand  # Context availabe, expand.
        :   $self->text;   # Context unavailable, do not expand.
}


sub _is_valid_context {
    my ($self, $require, $server, $request) = @_;
    if (not UNIVERSAL::isa($server, 'Mail::SPF::Server')) {
        throw Mail::SPF::EMacroExpansionCtxRequired('Mail::SPF server object required') if $require;
        return FALSE;
    }
    if (not UNIVERSAL::isa($request, 'Mail::SPF::Request')) {
        throw Mail::SPF::EMacroExpansionCtxRequired('Request object required') if $require;
        return FALSE;
    }
    return TRUE;
}


TRUE;