Mail::SPF::Result - SPF result class

    package Mail::SPF::Foo;
    use Error ':try';
    use Mail::SPF::Result;

    sub foo {
        if (...) {
            $server->throw_result('pass', $request)
        }
        else {
            $server->throw_result('permerror', $request, 'Invalid foo');
        }
    }

    package Mail::SPF::Bar;
    use Error ':try';
    use Mail::SPF::Foo;

    try {
        Mail::SPF::Foo->foo();
    }
    catch Mail::SPF::Result with {
        my ($result) = @_;
        ...
    };

    my $result_name     = $result->name;
    my $result_code     = $result->code;
    my $request         = $result->request;
    my $local_exp       = $result->local_explanation;
    my $authority_exp   = $result->authority_explanation
        if $result->can('authority_explanation');
    my $spf_header      = $result->received_spf_header;

#
# Mail::SPF::Result
# SPF result class.
#
# (C) 2005-2009 Julian Mehnle <julian@mehnle.net>
# $Id: Result.pm 53 2009-10-31 21:40:08Z Julian Mehnle $
#
##############################################################################

package Mail::SPF::Result;

use warnings;
use strict;

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

use base 'Error', 'Mail::SPF::Base';
    # An SPF result is not really a code exception in ideology, but in form.
    # The Error base class fits our purpose, anyway.

use Mail::SPF::Util;

use Error ':try';

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

use constant result_classes => {
    pass        => 'Mail::SPF::Result::Pass',
    fail        => 'Mail::SPF::Result::Fail',
    softfail    => 'Mail::SPF::Result::SoftFail',
    neutral     => 'Mail::SPF::Result::Neutral',
   'neutral-by-default'
                => 'Mail::SPF::Result::NeutralByDefault',
    none        => 'Mail::SPF::Result::None',
    error       => 'Mail::SPF::Result::Error',
    permerror   => 'Mail::SPF::Result::PermError',
    temperror   => 'Mail::SPF::Result::TempError'
};

use constant received_spf_header_name => 'Received-SPF';

use constant received_spf_header_scope_names_by_scope => {
    helo        => 'helo',
    mfrom       => 'mailfrom',
    pra         => 'pra'
};

use constant received_spf_header_identity_key_names_by_scope => {
    helo        => 'helo',
    mfrom       => 'envelope-from',
    pra         => 'pra'
};

use constant atext_pattern              => qr/[\p{IsAlnum}!#\$%&'*+\-\/=?^_`{|}~]/;

use constant dot_atom_pattern           => qr/
        (${\atext_pattern})+ ( \. (${\atext_pattern})+ )*
/x;

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

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

sub new {
    my ($self, @args) = @_;
    
    local $Error::Depth = $Error::Depth + 1;
    
    $self =
        ref($self) ?                        # Was new() involed on a class or an object?
            bless({ %$self }, ref($self))   # Object: clone source result object.
        :   $self->SUPER::new();            # Class:  create new result object.
    
    # Set/override fields:
    $self->{server}  = shift(@args) if @args;
    defined($self->{server})
        or throw Mail::SPF::EOptionRequired('Mail::SPF server object required');
    $self->{request} = shift(@args) if @args;
    defined($self->{request})
        or throw Mail::SPF::EOptionRequired('Request object required');
    $self->{'-text'} = shift(@args) if @args;
    
    return $self;
}

sub throw {
    my ($self, @args) = @_;
    local $Error::Depth = $Error::Depth + 1;
    $self = $self->new(@args);
        # Always create/clone a new result object, not just when throwing for the first time!
    die($Error::THROWN = $self);
}

# This method being implemented here does not make it any less abstract,
# because the code() method it uses is still abstract.
sub name {
    my ($self) = @_;
    return $self->code;
}

sub class {
    my ($self, $name) = @_;
    return defined($name) ? $self->result_classes->{lc($name)} : (ref($self) || $self);
}

sub isa_by_name {
    my ($self, $name) = @_;
    my $suspect_class = $self->class($name);
    return FALSE if not defined($suspect_class);
    return $self->isa($suspect_class);
}

sub is_code {
    my ($self, $code) = @_;
    return $self->isa_by_name($code);
}

# Read-only accessors:
__PACKAGE__->make_accessor($_, TRUE)
    foreach qw(server request);

sub stringify {
    my ($self) = @_;
    return sprintf("%s (%s)", $self->name, $self->SUPER::stringify);
}

sub local_explanation {
    my ($self) = @_;
    my $local_explanation = $self->{local_explanation};
    
    return $local_explanation
        if defined($local_explanation);
    
    # Prepare local explanation:
    my $request = $self->{request};
    $local_explanation = $request->state('local_explanation');
    if (defined($local_explanation)) {
        $local_explanation = sprintf("%s (%s)", $local_explanation->expand, lcfirst($self->text));
    }
    else {
        $local_explanation = $self->text;
    }
    
    # Resolve authority domains of root-request and bottom sub-request:
    my $root_request = $request->root_request;
    $local_explanation =
        $request == $root_request ?
            sprintf("%s: %s", $request->authority_domain, $local_explanation)
        :   sprintf("%s ... %s: %s",
                $root_request->authority_domain, $request->authority_domain, $local_explanation);
    
    return $self->{local_explanation} = $local_explanation;
}

sub received_spf_header {
    my ($self) = @_;
    return $self->{received_spf_header}
        if defined($self->{received_spf_header});
    my $scope_name =
        $self->received_spf_header_scope_names_by_scope->{$self->{request}->scope};
    my $identity_key_name =
        $self->received_spf_header_identity_key_names_by_scope->{$self->{request}->scope};
    my @info_pairs = (
        receiver            => $self->{server}->hostname || 'unknown',
        identity            => $scope_name,
        $identity_key_name  => $self->{request}->identity,
        (
            ($self->{request}->scope ne 'helo' and defined($self->{request}->helo_identity)) ?
                (helo       => $self->{request}->helo_identity)
            :   ()
        ),
        'client-ip'         => Mail::SPF::Util->ip_address_to_string($self->{request}->ip_address)
    );
    my $info_string;
    while (@info_pairs) {
        my $key   = shift(@info_pairs);
        my $value = shift(@info_pairs);
        $info_string .= '; ' if defined($info_string);
        if ($value !~ /^${\dot_atom_pattern}$/o) {
            $value =~ s/(["\\])/\\$1/g;   # Escape '\' and '"' characters.
            $value = '"' . $value . '"';  # Double-quote value.
        }
        $info_string .= "$key=$value";
    }
    return $self->{received_spf_header} = sprintf(
        "%s: %s (%s) %s",
        $self->received_spf_header_name,
        $self->code,
        $self->local_explanation,
        $info_string
    );
}

package Mail::SPF::Result::Pass;
our @ISA = 'Mail::SPF::Result';
use constant code => 'pass';

package Mail::SPF::Result::Fail;
our @ISA = 'Mail::SPF::Result';
use Error ':try';
use Mail::SPF::Exception;
use constant code => 'fail';

sub authority_explanation {
    my ($self) = @_;
    my $authority_explanation = $self->{authority_explanation};
    
    return $authority_explanation
        if defined($authority_explanation);
    
    my $server  = $self->{server};
    my $request = $self->{request};
    
    my $authority_explanation_macrostring = $request->state('authority_explanation');
    
    # If an explicit explanation was specified by the authority domain...
    if (defined($authority_explanation_macrostring)) {
        try {
            # ... then try to expand it:
            $authority_explanation = $authority_explanation_macrostring->expand;
        }
        catch Mail::SPF::EInvalidMacroString with {};
            # Ignore expansion errors and leave authority explanation undefined.
    }
    
    # If no authority explanation could be determined so far...
    if (not defined($authority_explanation)) {
        # ... then use the server's default authority explanation:
        $authority_explanation =
            $server->default_authority_explanation->new(request => $request)->expand;
    }
    
    return $self->{authority_explanation} = $authority_explanation;
}

package Mail::SPF::Result::SoftFail;
our @ISA = 'Mail::SPF::Result';
use constant code => 'softfail';

package Mail::SPF::Result::Neutral;
our @ISA = 'Mail::SPF::Result';
use constant code => 'neutral';

package Mail::SPF::Result::NeutralByDefault;
our @ISA = 'Mail::SPF::Result::Neutral';
use constant name => 'neutral-by-default';
    # This is a special-case of the Neutral result that is thrown as a default
    # when "falling off" the end of the record.  See Mail::SPF::Record::eval().

package Mail::SPF::Result::None;
our @ISA = 'Mail::SPF::Result';
use constant code => 'none';

package Mail::SPF::Result::Error;
our @ISA = 'Mail::SPF::Result';
use constant code => 'error';

package Mail::SPF::Result::PermError;
our @ISA = 'Mail::SPF::Result::Error';
use constant code => 'permerror';

package Mail::SPF::Result::TempError;
our @ISA = 'Mail::SPF::Result::Error';
use constant code => 'temperror';

package Mail::SPF::Result;

TRUE;