Mail::DKIM::Policy - abstract base class for originator "signing" policies

  # get all policies that apply to a verified message
  foreach my $policy ($dkim->policies)
  {

      # the name of this policy
      my $name = $policy->name;

      # the location in DNS where this policy was found
      my $location = $policy->location;

      # apply this policy to the message being verified
      my $result = $policy->apply($dkim);

  }

  my $result = $policy->apply($dkim_verifier);

  my $is_implied = $policy->is_implied_default_policy;

#!/usr/bin/perl

# Copyright 2005-2007 Messiah College.
# Jason Long <jlong@messiah.edu>

# Copyright (c) 2004 Anthony D. Urso. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

use strict;
use warnings;

package Mail::DKIM::Policy;

use Mail::DKIM::DNS;

sub fetch
{
	my $class = shift;
	my $waiter = $class->fetch_async(@_);
	return $waiter->();
}

sub fetch_async
{
	my $class = shift;
	my %prms = @_;

	($prms{'Protocol'} eq "dns")
		or die "invalid protocol '$prms{Protocol}'\n";

	my $host = $class->get_lookup_name(\%prms);
	my %callbacks = %{$prms{Callbacks} || {}};
	my $on_success = $callbacks{Success} || sub { $_[0] };
	$callbacks{Success} = sub {
			my $resp = shift;
			unless ($resp)
			{
				# no response => NXDOMAIN, use default policy
				return $on_success->($class->default);
			}

			my $strn;
			foreach my $ans ($resp) {
				next unless $ans->type eq "TXT";
				$strn = join "", $ans->char_str_list;
			}

			unless ($strn)
			{
				# empty record found in DNS, use default policy
				return $on_success->($class->default);
			}

			my $self = $class->parse(
					String => $strn,
					Domain => $prms{Domain},
					);
			return $on_success->($self);
		};

	#
	# perform DNS query for domain policy...
	#
	my $waiter = Mail::DKIM::DNS::query_async(
			$host, "TXT",
			Callbacks => \%callbacks,
			);
	return $waiter;
}

sub parse
{
	my $class = shift;
	my %prms = @_;

	my $text = $prms{"String"};
	my %tags;
	foreach my $tag (split /;/, $text)
	{
		# strip whitespace
		$tag =~ s/^\s+|\s+$//g;

		my ($tagname, $value) = split /=/, $tag, 2;
		unless (defined $value)
		{
			die "policy syntax error\n";
		}

		$tagname =~ s/\s+$//;
		$value =~ s/^\s+//;
		$tags{$tagname} = $value;
	}

	$prms{tags} = \%tags;
	return bless \%prms, $class;	
}

sub apply
{
	my $self = shift;
	my ($dkim) = @_;

	my $first_party;
	foreach my $signature ($dkim->signatures)
	{
		next if $signature->result ne "pass";

		my $oa = $dkim->message_sender->address;
		if ($signature->identity_matches($oa))
		{
			# found a first party signature
			$first_party = 1;
			last;
		}
	}

	return "accept" if $first_party;
	return "reject" if ($self->signall && !$self->testing);
	return "neutral";
}

sub as_string
{
       my $self = shift;

       return join("; ", map { "$_=" . $self->{tags}->{$_} }
               keys %{$self->{tags}});
}

sub is_implied_default_policy
{
	my $self = shift;
	my $default_policy = ref($self)->default;
	return ($self == $default_policy);
}

sub location
{
	my $self = shift;
	return $self->{Domain};
}

1;