=head1 NAME

Mail::SPF::Iterator - iterative SPF lookup

=head1 SYNOPSIS

	use Net::DNS;
	use Mail::SPF::Iterator;
	use Mail::SPF::Iterator Debug =>1; # enable debugging
	my $spf = Mail::SPF::Iterator->new(
		$ip,       # IP4|IP6 of client
		$mailfrom, # from MAIL FROM:
		$helo,     # from HELO|EHLO
		$myname,   # optional: my hostname
	);

	# could be other resolvers too
	my $resolver = Net::DNS::Resolver->new;

	### with nonblocking, but still in loop
	### (callbacks are preferred with non-blocking)
	my ($result,@ans) = $spf->next; # initial query
	while ( ! $result ) {
		my @query = @ans;
		die "no queries" if ! @query;
		for my $q (@query) {
			# resolve query
			my $socket = $resolver->bgsend( $q );
			... wait...
			my $answer = $resolver->bgread($socket);
			($result,@ans) = $spf->next(
				$answer                             # valid answer
				|| [ $q, $resolver->errorstring ]   # or DNS problem
			);
			last if $result; # got final result
			last if @ans;    # got more DNS queries
		}
	}

	### OR with blocking:
	### ($result,@ans) = $spf->lookup_blocking( undef,$resolver );

	### print mailheader
	print "Received-SPF: ".$spf->mailheader;

	# $result = Fail|Pass|...
	# $ans[0] = comment for Received-SPF
	# $ans[1] = %hash with infos for Received-SPF
	# $ans[2] = explanation in case of Fail



=head1 DESCRIPTION

This module provides an iterative resolving of SPF records. Contrary to
Mail::SPF, which does blocking DNS lookups, this module just returns the DNS
queries and later expects the responses.

Lookup of the DNS records will be done outside of the module and can be done
in a event driven way.

This module can also make use of SenderID records for checking the C<mfrom>
part, but only if it finds an SenderID record first (e.g. if the SPF reply
contains only SenderID and the the TXT SenderID and SPF and it gets the SPF
reply first it will use SenderID, if it gets TXT first it will use SPF).

This behavior is not compatible with RFC4406 where SenderID records take
preference, but compatible with RFC4408 in that it uses SPF records and
provides a way to use SenderID if no SPF records are given.

See RFC4408 for SPF and RFC4406 for SenderID.

=head1 METHODS

=over 4

=item new( IP, MAILFROM, HELO, [ MYNAME ] )

Construct a new Mail::SPF::Iterator object, which maintains the state
between the steps of the iteration. For each new SPF check a new object has
to be created.

IP is the IP if the client as string (IP4 or IP6).

MAILFROM is the user@domain part from the MAIL FROM handshake, e.g. '<','>'
and any parameters removed. If only '<>' was given (like in bounces) the
value is empty.

HELO is the string send within the HELO|EHLO dialog which should be a domain
according to the RFC but often is not.

MYNAME is the name of the local host. It's only used if required by macros
inside the SPF record.

Returns the new object.

=item next([ ANSWER ])

C<next> will be initially called with no arguments to get initial DNS queries
and then will be called with the DNS answers.

ANSWER is either a DNS packet with the response to a former query or C<< [
QUERY, REASON ] >> on failures, where QUERY is the DNS packet containing the
failed query and REASON the reason, why the query failed (like TIMEOUT).

If a final result was achieved it will return
C<< ( RESULT, COMMENT, HASH, EXPLAIN ) >>. RESULT is the result, e.g. "Fail",
"Pass",.... COMMENT is the comment for the Received-SPF header. HASH contains
information about problem, mechanism for the Received-SPF header.
EXPLAIN will be set to the explain string if RESULT is Fail.

=item mailheader

Creates value for Received-SPF header based on the final answer from next().
Returns header as string (one line, no folding) or undef, if no final result
was found.
This creates only the value, not the 'Received-SPF' prefix.

=item result

Returns ( RESULT, COMMENT, HASH, EXPLAIN ) like the final C<next> does or () if
the final result wasn't found yet.

If the SPF record had an explain modifier, which needed DNS lookups to resolve
this method might return the result (although with incomplete explain) before
C<next> does it.

=item explain_default ( [ EXPLAIN ] )

Sets default explanation string if EXPLAIN is given.
If it's called as a class method the default explanation string for the class
will be set, otherwise the default explanation string for the object.

Returns the current default explanation string for the object or if non
given or if called as a class method the default explanation string for the
class.

=item lookup_blocking ( [ TIMEOUT, RESOLVER ] )

Quick way to get the SPF status.
This will simply call C<next> until it gets a final result.

TIMEOUT limits the lookup time and defaults to 20.
RESOLVER is a Net::DNS::Resolver object (or similar) and  defaults to
C<< Net::DNS::Resolver->new >>.
Returns ( RESULT, COMMENT, HASH ) like the final C<next> does.

This is not the preferred way to use this module, because it's blocking, so
no lookups can be done in parallel in a single process/thread.

=back

=head1 EXPORTED SYMBOLS

For convenience the constants SPF_TempError, SPF_PermError, SPF_Pass, SPF_Fail,
SPF_SoftFail, SPF_Neutral, SPF_None are by default exported, which have the values
C<"TempError">, C<"PermError"> ...

=head2 Arguments to C<use>/C<import>

The C<SPF_*> symbols are available for import and are exported if no arguments
are given to C<use> or C<import>. Same effect with adding C<:DEFAULT> as an
argument. Additionally the following arguments are supported:

=over 4

=item DebugFunc => \&coderef

Sets a custom debug function, which just takes on argument. If given it will be
called on all debug messages when debugging is active. This function takes as
the only argument the debug message.

=item Debug => 1|0

Switches debugging on/off.

=back

=head1 AUTHOR

Steffen Ullrich <sullr@cpan.org>

=head1 COPYRIGHT

Copyright by Steffen Ullrich.

This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut


use strict;
use warnings;

package Mail::SPF::Iterator;

our $VERSION = '1.06';

use fields (
	# values given in or derived from params to new()
	'helo',            # helo given in new()
	'myname',          # myname given in new()
	'clientip4',       # packed ip from new() if IP4
	'clientip6',       # packed ip from new() if IP6
	'sender',          # mailfrom|helo given in new()
	'domain',          # extracted from mailfrom|helo
	'identity',        # 'mailfrom' if sender is mailfrom, else 'helo'
	# internal states and values
	'mech',            # list of unhandled mechanism for current SPF
	'include_stack',   # stack for handling includes
	'redirect',        # set to domain of redirect modifier of current SPF
	'explain',         # set to explain modifier of current SPF
	'cb',              # [$sub,@arg] for callback to DNS replies
	'cbq',             # list of queries from last mech incl state
	'validated',       # cache used in validation of hostnames for ptr and %{p}
	'limit_dns_mech',  # countdown for number of mechanism using DNS queries
	'explain_default', # default explanation of object specific
	'result',          # contains final result
);

use Net::DNS;
use Socket;
use URI::Escape 'uri_escape';
use Data::Dumper;
use base 'Exporter';


### Socket6 is not yet perl core, so check, if we can use it. Otherwise we
### hopefully don't get any IP6 data, so no need to use it.
my $can_ip6;
BEGIN {

	$can_ip6 = 0;
	$can_ip6 = eval {
		require Socket6;
		Socket6->import(qw( inet_pton inet_ntop));
		# newer Socket versions already export AF_INET6
		Socket6->import('AF_INET6') if ! defined &AF_INET6;
		1;
	};
	if ( ! $can_ip6 ) {
		no strict 'refs';
		*{'AF_INET6'} = *{'inet_pton'} = *{'inet_ntop'}
			= sub { die "no IPv6 support" };
	}
}

### create SPF_* constants and export them
our @EXPORT;
use constant SPF_Noop => '_NOOP';
BEGIN {
	for (qw(TempError PermError Pass Fail SoftFail Neutral None )) {
		no strict 'refs';
		*{"SPF_$_"} = eval "sub () { '$_' }";
		push @EXPORT, "SPF_$_";
	}
}

my $DEBUGFUNC;
my $DEBUG=0;
sub import {
	goto &Exporter::import if @_ == 1; # implicit :DEFAULT
	my $i = 1;
	while ( $i<@_ ) {
		if ( $_[$i] eq 'DebugFunc' ) {
			$DEBUGFUNC = $_[$i+1];
			splice( @_,$i,2 );
			next;
		} elsif ( $_[$i] eq 'Debug' ) {
			$DEBUG = $_[$i+1];
			splice( @_,$i,2 );
			next;
		}
		++$i;
	}
	goto &Exporter::import if @_ >1; # not implicit :DEFAULT
}



### Debugging
sub DEBUG {
	$DEBUG or return; # check against debug level
	goto &$DEBUGFUNC if $DEBUGFUNC;
	my (undef,$file,$line) = caller;
	my $msg = shift;
	# limit filename to 20
	$file = '...'.substr( $file,-17 ) if length($file)>20;
	$msg = sprintf $msg,@_ if @_;
	print STDERR "DEBUG: $file:$line: $msg\n";
}

### pre-compute masks for IP4, IP6
my (@mask4,@mask6);
{
	my $m = '0' x 32;
	$mask4[0] = pack( "B32",$m);
	for (1..32) {
		substr( $m,$_-1,1) = '1';
		$mask4[$_] = pack( "B32",$m);
	}

	$m = '0' x 128;
	$mask6[0] = pack( "B32",$m);
	for (1..128) {
		substr( $m,$_-1,1) = '1';
		$mask6[$_] = pack( "B128",$m);
	}
}

### mapping char to result
my %qual2rv = (
	'+' => SPF_Pass,
	'-' => SPF_Fail,
	'~' => SPF_SoftFail,
	'?' => SPF_Neutral,
);

############################################################################
# NEW
# creates new SPF processing object
# Args: ($class,$ip,$mailfrom,$helo,$myname)
#  $ip: IP4/IP6 as string
#  $mailfrom: user@domain of "mail from"
#  $helo: info from helo|ehlo - should be domain name
#  $myname: local name, used only for expanding macros
# Returns: $self
############################################################################
sub new {
	my ($class,$ip,$mailfrom,$helo,$myname) = @_;
	my Mail::SPF::Iterator $self = fields::new($class);

	my $domain =
		$mailfrom =~m{\@([\w\-.]+)$} ? $1 :
		$mailfrom =~m{\@\[([\da-f:\.]+)\]$}i ? $1 :
		$helo =~m{\@([\w\-.]+)$} ? $1 :
		$helo =~m{\@\[([\da-f:\.]+)\]$}i ? $1 :
		$helo;
	my ($sender,$identity) = $mailfrom ne ''
		? ( $mailfrom,'mailfrom' )
		: ( $helo,'helo' );

	my $ip4 = eval { inet_aton($ip) };
	my $ip6 = ! $ip4 && $can_ip6 && eval { inet_pton(AF_INET6,$ip) };
	die "no client IP4 or IP6 known (can_ip6=$can_ip6): $ip"
		if ! $ip4 and ! $ip6;

	if ( $ip6 ) {
		my $m = inet_pton( AF_INET6,'::ffff:0.0.0.0' );
		if ( ($ip6 & $m) eq $m ) {
			# mapped IPv4
			$ip4 = substr( $ip6,-4 );
			$ip6 = undef;
		}
	}

	%$self = (
		clientip4 => $ip4,     # IP of client
		clientip6 => $ip6,     # IP of client
		domain => $domain,     # current domain
		sender => $sender,     # sender (mailfrom|helo)
		helo   => $helo,       # helo
		identity => $identity, # 'helo'|'mailfrom'
		myname => $myname,     # name of mail host itself
		include_stack => [],   # stack in case of include
		cb => undef,           # callback for next DNS reply
		cbq => [],             # the DNS queries for cb
		validated => {},       # validated IP/domain names for PTR and %{p}
		limit_dns_mech => 10,  # Limit on Number of DNS mechanism
		mech => undef,         # list of spf mechanism
		redirect => undef,     # redirect from SPF record
		explain => undef,      # explain from SPF record
		result => undef,       # final result [ SPF_*, info, \%hash ]
	);
	return $self;
}

############################################################################
# return result
# Args: $self
# Returns: ($status,$info,$hash,$explain)
#  $status: SPF_Pass|SPF_Fail|...
#  $info:   comment for Received-SPF header
#  $hash:   param for Received-SPF header
#  $explain: explanation string on SPF_Fail
############################################################################
sub result {
	my Mail::SPF::Iterator $self = shift;
	my $r = $self->{result} or return;
	return @$r;
}

############################################################################
# get/set default explanation string
# Args: ($self,[$explain])
#  $explain: default explanation string (will be set)
# Returns: $explain
#  $explain: default explanation string
############################################################################
{
	my $default = 'SPF Check Failed';
	sub explain_default {
		if ( ref $_[0] ) {
			my Mail::SPF::Iterator $self = shift;
			$self->{explain_default} = shift if @_;
			return defined $self->{explain_default}
				? $self->{explain_default}
				: $default;
		} else {
			shift; # class
			$default = shift if @_;
			return $default;
		}
	}
}

############################################################################
# lookup blocking
# not the intended way to use the module, but sometimes one needs to quickly
# lookup something, even if it's blocking
# Args: ($self,[$timeout,$resolver])
#  $timeout: total timeout for lookups, default 20
#  $resolver: Resolver object compatible to Net::DNS::Resolver, if not
#      given a new Net::DNS::Resolver object will be created
# Returns: ($status,$info,$hash,$explain)
#  see result()
############################################################################
sub lookup_blocking {
	my Mail::SPF::Iterator $self = shift;
	my ($timeout,$resolver) = @_;

	my $expire = time() + ( $timeout || 20 ); # 20s: RFC4408, 10.1
	$resolver ||= Net::DNS::Resolver->new;

	my ($status,@ans) = $self->next; # get initial queries
	while ( ! $status ) {

		# expired ?
		$timeout = $expire - time();
		last if $timeout < 0;

		my @query = @ans;
		die "no more queries but no final status" if ! @query;
		for my $q (@query) {
			#DEBUG( "next query: ".$q->string );
			my $socket = $resolver->bgsend( $q );

			my $rin = '';
			vec( $rin,fileno($socket),1) = 1;
			select( $rin,undef,undef,$timeout ) or last;

			my $answer = $resolver->bgread( $socket );
			($status,@ans) = $self->next(
				$answer || [ $q, $resolver->errorstring ]
			);
			last if $status or @ans;
		}
	}
	my @rv = ! $status
		? ( SPF_TempError,'', { problem => 'DNS lookups timed out' } )
		: ($status,@ans);
	return wantarray ? @rv : $status;
}

############################################################################
# mailheader
# create value for Received-SPF header for final response
# Args: $self
# Returns: $hdrvalue
############################################################################
sub mailheader {
	my Mail::SPF::Iterator $self = shift;
	my ($result,$info,$hash) = @{ $self->{result} || return };
	my $t = "$result ";
	my %t = (
		%{ $hash || {} },
		'client-ip' => (
			$self->{clientip4}
				? inet_ntoa($self->{clientip4})
				: inet_ntop(AF_INET6,$self->{clientip6})
			),
		helo => $self->{helo},
		identity => $self->{identity},
	);
	for ( values(%t)) {
		# Quote: this is not exactly rfc2822 but should be enough
		s{([\"\\])}{\\$1}g;
		$_ = qq("$_") if m{[\s;()]} or $_ eq '';
	}
	$t{'envelope-from'} = "<$self->{sender}>" if $self->{sender};
	$t .= join( "; ", map { "$_=$t{$_}" } sort keys %t );
	return $t;
}

############################################################################
# next step in SPF lookup
# - verify that there are open queries for the DNS reply and that parameter
#   in query match question+answer in reply
# - process dnsresp by the current callback
# - process callbacks result using _next_process_cbrv which returns either
#   final result or more DNS questions
# Args: ($self,$dnsresp)
#   $dnsresp: DNS reply
# Returns: (undef,@dnsq) | ($status,$info,\%param,$explain) | ()
#   (undef,@dnsq): @dnsq are more DNS questions
#   ($status,$info,\%param,$explain): final response
#   (): reply ignored, waiting for next reply
############################################################################
sub next {
	my Mail::SPF::Iterator $self = shift;
	my $dnsresp = shift;

	if ( ! $dnsresp ) {
		# no DNS response - must be initial call to next
		die "no DNS reply but callback given" if $self->{cb};
		return $self->_next_process_cbrv( $self->_query_txt_spf );
	}

	# handle DNS reply
	my $callback = $self->{cb} or die "no callback but DNS reply";
	my $cb_queries = $self->{cbq};
	if ( ! @$cb_queries ) {
		# we've got a reply, but no outstanding queries - ignore
		DEBUG( "got reply w/o queries, ignoring" );
		return;
	}

	# extract query from reply
	my ($question,$err,$qid);
	if ( ! UNIVERSAL::isa( $dnsresp, 'Net::DNS::Packet' )) {
		# probably [ $question, $errorstring ]
		(my $query,$err) = @$dnsresp;
		($question) = $query->question;
		$qid = $query->header->id;
		$err ||= 'unknown error';
		$dnsresp = $err;
		DEBUG( "error '$err' to query ".$question->string );
	} else {
		($question) = $dnsresp->question;
		$qid = $dnsresp->header->id;
	}
	my $qtype = $question->qtype;

	# check if the reply matches one of the open queries
	my $found;
	for (@$cb_queries) {
		next if $qid != $_->{id}; # ID mismatch

		# presentation2wire
		# $_->{q}->qname has still the raw (wire) value, because it was set to
		# it but the qname of the response has the human readable presentation
		# from the zonefiles :(
		# fortunatly this applies only to DNS names with special chars
		# see Net::DNS::wire2presentation
		( my $qname = lc($question->qname) )
			=~s{\\(?:(\d\d\d)|(.))}{ $2 || chr($1) }esg;

		if ( $qtype eq $_->{q}->qtype and $qname eq lc($_->{q}->qname)) {
			$found = $_;
			last;
		}
	}

	if ( ! $found ) {
		# unexpected response, type or domain do not match query -> TempError
		my %want = map { $_->{q}->qtype => 1 } @$cb_queries;
		my %name = map { $_->{q}->qname => 1 } @$cb_queries;
		DEBUG( "found no open query for ".$question->string );
		return ( SPF_TempError,
			"getting ".join("|",keys %want)." for ".join("|",keys %name),
			{ problem => "unexpected DNS response" },
		);
	} elsif ( ++$found->{done} > 1 ) {
		# duplicate response - ignore
		DEBUG( "duplicate response, ignoring" );
		return;
	}

	# found matching query
	# check for error
	if ( $err ) {
		if ( grep { ! $_->{done} } @$cb_queries ) {
			# we still have outstanding queries, so we might still get answers
			# -> return () as a sign, that we ignore this error
			DEBUG( "ignore error '$err', we still have oustanding queries" );
			return;

		} elsif ( my $r = $self->{result} ) {
			# we have a final result already, so this error occured only while
			# trying to expand %{p} for explain
			# -> ignore error, set to default explain and return final result
			DEBUG( "error looking up data for explain: $err" );
			return @$r;

		} else {
			# we have no final result yet -> TempError
			DEBUG( "TempError: $err" );
			my %want = map { $_->{q}->qtype => 1 } @$cb_queries;
			my %name = map { $_->{q}->qname => 1 } @$cb_queries;
			my @rv = ( SPF_TempError,
				"getting ".join("|",keys %want)." for ".join("|",keys %name),
				{ problem => "error getting DNS response" }
			);
			$self->{result} = \@rv;
			return @rv;
		}
	}


	# call callback with no records on error
	my $rcode = $dnsresp->header->rcode;
	if ( $rcode ne 'NOERROR' ) {
		my ($sub,@arg) = @$callback;
		return $self->_next_process_cbrv(
			$sub->($self,$qtype,$rcode,[],[],@arg));
	}

	# extract answer and additional data
	# verify if names and types in answer records match query
	# handle CNAMEs
	my $qname = $question->qname;
	$qname =~s{\\(?:(\d\d\d)|(.))}{ $2 || chr($1) }esg; # presentation -> raw
	my (%cname,%ans);
	for my $rr ($dnsresp->answer) {
		my $rtype = $rr->type;
		# changed between Net::DNS 0.63 and 0.64 
		# it reports now the presentation name instead of the raw name
		( my $name = $rr->name ) =~s{\\(?:(\d\d\d)|(.))}{ $2 || chr($1) }esg;
		if ( $rtype eq 'CNAME' ) {
			# remember CNAME so that we can check that the answer record
			# for $qtype matches name from query or CNAME which is an alias
			# for name
			if ( exists $cname{$name} ) {
				DEBUG( "more than one CNAME for same name" );
				next; # XXX should we TempError instead of ignoring?
			}
			$cname{$name} = $rr->cname;
		} elsif ( $rtype eq $qtype ) {
			push @{ $ans{$name}},$rr;
		} else {
			# XXXX should we TempError instead of ignoring?
			DEBUG( "unexpected answer record for $qtype:$qname" );
		}
	}

	# find all valid names, usually there should be at most one CNAME
	# works by starting with name from query, finding CNAMEs for it,
	# adding these to set and finding next CNAMEs etc
	# if there are unconnected CNAMEs they will be left in %cname
	my @names = ($qname);
	while ( %cname ) {
		push @names, delete @cname{@names} or last;
	}
	if ( %cname ) {
		# Report but ignore - XXX should we TempError instead?
		DEBUG( "unrelated CNAME records ".Dumper(\%cname));
	}

	# collect the RR for all valid names
	my @ans;
	for (@names) {
		my $rrs = delete $ans{$_} or next;
		push @ans,@$rrs;
	}
	if ( %ans ) {
		# answer records which don't match name from query or via CNAME
		# derived names
		# Report but ignore - XXX should we TempError instead?
		DEBUG( "unrelated answer records for $qtype names=@names ".Dumper(\%ans));
	}

	if ( ! @ans and @names>1 ) {
		# according to RFC1034 all RR for the type should be put into
		# the answer section together with the CNAMEs
		# so if there are no RRs in this answer, we should assume, that
		# there will be no RRs at all
		DEBUG( "no answer records for $qtype, but names @names" );
	}

	my ($sub,@arg) = @$callback;
	return $self->_next_process_cbrv(
		$sub->($self,$qtype,$rcode,\@ans,[ $dnsresp->additional ],@arg));
}

############################################################################
# process results from callback to DNS reply, called from next
# Args: ($self,@rv)
#  @rv: result from callback, either
#       @query - List of new Net::DNS::Packet queries for next step
#       ()     - no result (go on with next step)
#       (status,...) - final response
# Returns: ... - see sub next
############################################################################
sub _next_process_cbrv {
	my Mail::SPF::Iterator $self = shift;
	my @rv = @_; # results from callback to _mech*

	# resolving of %{p} in exp= mod or explain TXT results in @rv = ()
	# see sub _validate_*
	if ( $self->{result} && ! @rv ) {
		# set to final result
		@rv = @{ $self->{result}};
	}

	# if the last mech (which was called with the DNS reply in sub next) got
	# no match and no further questions we need to find the match or questions
	# either by processing the next mech in the current SPF record, following
	# a redirect or going the include stack up
	@rv = $self->_next_mech if ! @rv;

	if ( UNIVERSAL::isa( $rv[0],'Net::DNS::Packet' )) {
		# @rv is list of DNS packets
		return $self->_next_rv_dnsq(@rv)
	}

	# @rv is (status,...)
	# status of SPF_Noop is special in that it returns nothing as a sign, that
	# it just waits for more input
	# Only used when we could get multiple responses, e.g when multiple DNS
	# requests were send like in the query for SPF+TXT
	if ( $rv[0] eq SPF_Noop ) {
		die "NOOP but no open queries"
			if ! grep { ! $_->{done} } @{$self->{cbq}};
		return;
	}

	# If inside include response is only pre-final
	# propagate it the include stack up:
	# see RFC4408, 5.2 for propagation of results
	while ( my $top = pop @{ $self->{include_stack} } ) {
		DEBUG( "pre-final response $rv[0]" );

		if ( $rv[0] eq SPF_TempError || $rv[0] eq SPF_PermError ) {
			# keep
		} elsif ( $rv[0] eq SPF_None ) {
			$rv[0] = SPF_PermError; # change None to PermError
		} else {
			# go stack up, restore saved data
			my $qual = delete $top->{qual};
			while ( my ($k,$v) = each %$top ) {
				$self->{$k} = $v;
			}
			if ( $rv[0] eq SPF_Pass ) {
				# Pass == match -> set status to $qual
				$rv[0] = $qual;
			} else {
				# ! Pass == non-match
				# -> restart with @rv=() and go on with next mech
				@rv = $self->_next_mech;
			}
		}
	}

	# no more include stack
	# -> @rv is the final result, save it
	my $final = $self->{result} ||= [ @rv ];

	# now the only things left is to handle explain in case of SPF_Fail
	return @$final if $final->[0] ne SPF_Fail; # finally done

	# set default explanation
	$final->[3] = $self->explain_default if ! defined $final->[3];

	# lookup TXT record for explain
	if ( my $exp = delete $self->{explain} ) {
		if (ref $exp) {
			if ( my @dnsq = $self->_resolve_macro_p($exp)) {
				# we need to do more DNS lookups for resolving %{p} macros
				# inside the exp=... modifier, before we get the domain name
				# which contains the TXT for explain
				DEBUG( "need to resolve %{p} in $exp->{macro}" );
				$self->{explain} = $exp; # put back until resolved
				return $self->_next_rv_dnsq(@dnsq)
			}
			$exp = $exp->{expanded};
		}
		if ( my @err = _check_domain( $exp, "explain:$exp" )) {
			# bad domain: return unmodified final
			return @$final;
		}
		DEBUG( "lookup TXT for '$exp' for explain" );
		$self->{cb} = [ \&_got_TXT_exp ];
		return $self->_next_rv_dnsq( Net::DNS::Packet->new($exp,'TXT','IN'));
	}

	# resolve macros in TXT record for explain
	if ( my $exp = delete $final->[4] ) {
		# we had a %{p} to resolve in the TXT we got for explain,
		# see _got_TXT_exp -> should be expanded now
		$final->[3] = $exp->{expanded};

	}

	# This was the last action needed
	return @$final;
}

############################################################################
# try to match or give more questions by
# - trying the next mechanism in the current SPF record
# - if there is no next mech try to redirect to another SPF record
# - if there is no redirect try to go include stack up
# - if there is no include stack return SPF_Neutral
# Args: $self
# Returns: @query|@final
#   @query: new queries as list of Net::DNS::Packets
#   @final: final SPF result (see sub next)
############################################################################
sub _next_mech {
	my Mail::SPF::Iterator $self = shift;

	for my $dummy (1) {

		# if we have more mechanisms in the current SPF record take next
		if ( my $next = shift @{$self->{mech}} ) {
			my ($sub,@arg) = @$next;
			my @rv = $sub->($self,@arg);
			redo if ! @rv; # still no match and no queries
			return @rv;
		}

		# if no mechanisms in current SPF record but we have a redirect
		# continue with the SPF record from the new location
		if ( my $domain = $self->{redirect} ) {
			if ( ref $domain ) {
				# need to resolve %{p}
				if ( $domain->{macro} and
					( my @rv = $self->_resolve_macro_p($domain))) {
					return @rv;
				}
				$self->{redirect} = $domain = $domain->{expanded};
			}
			if ( my @err = _check_domain($domain,"redirect:$domain" )) {
				 return @err;
			}

			return ( SPF_PermError, "",
				{ problem => "Number of DNS mechanism exceeded" })
				if --$self->{limit_dns_mech} < 0;

			# reset state information
			$self->{mech}     = [];
			$self->{explain}  = undef;
			$self->{redirect} = undef;

			# set domain to domain from redirect
			$self->{domain}   = $domain;

			# restart with new SPF record
			return $self->_query_txt_spf;
		}

		# if there are still no more mechanisms available and we are inside
		# an include go up the include stack
		my $st = $self->{include_stack};
		if (@$st) {
			my $top = pop @$st;
			delete $top->{qual};
			while ( my ($k,$v) = each %$top ) {
				$self->{$k} = $v;
			}
			# continue with mech or redirect of upper SPF record
			redo;
		}
	}

	# no mech, no redirect and no include stack
	# -> give up finally and return SPF_Neutral
	return ( SPF_Neutral,'no matches' );
}

############################################################################
# if @rv is list of DNS packets return them as (undef,@dnspkt)
# remember the queries so that the answers can later (sub next) verified
# against the queries
# Args: ($self,@dnsq)
#  @dnsq: list of Net::DNS::Packet's
# Returns: (undef,@dnsq)
############################################################################
sub _next_rv_dnsq {
	my Mail::SPF::Iterator $self = shift;
	my @dnsq = @_;
	# track queries for later verification
	my @cbq = map { { q => ($_->question)[0], id => $_->header->id } } @dnsq;
	$self->{cbq} = \@cbq;
	DEBUG( "need to lookup ".join( " | ",
		map { "'".$_->{id}.'/'.$_->{q}->string."'" } @cbq));
	return ( undef,@dnsq );
}

############################################################################
# check if the domain has the right format
# this checks the domain before the macros got expanded
############################################################################
sub _check_macro_domain {
	my ($domain,$why) = @_;
	# 'domain-spec': see RFC4408 Appendix A for ABNF
	my $rx = qr{
		# macro-string
		(?:
			[^%\s]+ |
			% (?: { [slodipvh] \d* r? [.\-+,/_=]* } | [%\-_] )
		)*
		# domain-end
		(?:(?:
			# toplabel
			\. [\da-z]*[a-z][\da-z]* |
			\. [\da-z]+-[\-a-z\d]*[\da-z]
		) | (?:
			# macro-expand
			% (?: { [slodipvh] \d* r? [.\-+,/_=]* } | [%\-_] )
		))
	}xi;
	_check_domain( $domain,$why,$rx);
}

############################################################################
# check if the domain has the right format
# this checks the domain after the macros got expanded
############################################################################
sub _check_domain {
	my ($domain,$why,$rx) = @_;
	$why = '' if ! defined $why;

	# domain name according to RFC2181 can be anything binary!
	# this is not only for host names
	$rx ||= qr{.*?};

	my @rv;
	if ( $domain =~m{[^\d.]}
		&& $domain =~s{^($rx)\.?$}{$1} ) {
		# looks like valid domain name
		if ( grep { length == 0 || length>63 } split( m{\.},$domain,-1 )) {
			@rv = ( SPF_PermError,"query $why", { problem =>
				"DNS labels limited to 63 chars and should not be empty." });
		} elsif ( length($domain)>253 ) {
			@rv = ( SPF_PermError,"query $why",
				{ problem => "Domain names limited to 253 chars." });
		} else {
			#DEBUG( "domain name ist OK" );
			return
		}
	} else {
		@rv = ( SPF_PermError, "query $why",
			{ problem => "Invalid domain name" });
	}

	DEBUG( "error with '$domain': ".$rv[2]{problem} );
	return @rv; # have error
}

############################################################################
# initial query
# returns queries for SPF and TXT record, next state is _got_txt_spf
############################################################################
sub _query_txt_spf {
	my Mail::SPF::Iterator $self = shift;
	DEBUG( "want SPF/TXT for $self->{domain}" );
	# return query for SPF and TXT, we see what we get first
	if ( my @err = _check_domain( $self->{domain}, "SPF/TXT record" )) {
		if ( ! $self->{cb} ) {
			# for initial query return SPF_None on errors
			$err[0] = SPF_None;
		}
		return @err;
	}

	$self->{cb} = [ \&_got_txt_spf ];
	return (
		scalar(Net::DNS::Packet->new( $self->{domain}, 'SPF','IN' )),
		scalar(Net::DNS::Packet->new( $self->{domain}, 'TXT','IN' )),
	);
}

############################################################################
# processes response to SPF|TXT query
# parses response and starts processing
############################################################################
sub _got_txt_spf {
	my Mail::SPF::Iterator $self = shift;
	my ($qtype,$rcode,$ans,$add) = @_;

	for my $dummy ( @$ans ? (1):() ) {
		# RFC4408 says in 4.5:
		# 2. If any records of type SPF are in the set, then all records of
		#    type TXT are discarded.
		# But it says that if both SPF and TXT are given they should be the
		# same (3.1.1)
		# so I think we can ignore the requirement 4.5.2 and just use the
		# first record which is valid SPF, if the admin of the domain sets
		# TXT and SPF to different values it's his own problem

		my (@spfdata,@senderid);
		for my $rr (@$ans) {
			my $txtdata = join( '', $rr->char_str_list );
			$txtdata =~m{^
				(?:
					(v=spf1)
					| spf2\.\d/(?:[\w,]*\bmfrom\b[\w,]*)
				)
				(?:$|\040\s*)(.*)
			}xi or next;
			if ( $1 ) {
				push @spfdata,$2;
				DEBUG( "got spf data for $qtype: $txtdata" );
			} else {
				push @senderid,$2;
				DEBUG( "got senderid data for $qtype: $txtdata" );
			}
		}

		# if SenderID and SPF are given prefer SPF, else use any
		@spfdata = @senderid if ! @spfdata;

		@spfdata or last; # no usable SPF reply
		if (@spfdata>1) {
			return ( SPF_PermError,
				"checking $qtype for $self->{domain}",
				{ problem => "multiple SPF records" }
			);
		}
		unless ( eval { $self->_parse_spf( $spfdata[0] ) }) {
			# this is an invalid SPF record
			# make it a permanent error
			# it does not matter if the other type of record is good
			# because according to RFC if both provide SPF (v=spf1..)
			# they should be the same, so the other one should be bad too
			return ( SPF_PermError,
				"checking $qtype for $self->{domain}",
				{ problem => "invalid SPF record: $@" }
			);
		}

		# looks good, return so that next() processes the next query
		return;
	}

	# If this is the first response, wait for the other
	DEBUG( "no records for $qtype ($rcode)" );
	if ( grep { ! $_->{done} } @{ $self->{cbq}} ) {
		return (SPF_Noop);
	}

	# otherwise it means that we got no SPF records
	# return SPF_None if this was the initial query ($self->{mech} is undef)
	# and SPF_PermError if as a result from redirect or include
	# ($self->{mech} is [])
	DEBUG( "no usable SPF/TXT records" );
	return ( $self->{mech} ? SPF_PermError : SPF_None,
		'query SPF/TXT record',
		{ problem => 'no SPF records found' });
}


############################################################################
# parse SPF record, returns 1 if record looks valid,
# otherwise die()s with somewhat helpful error message
############################################################################
sub _parse_spf {
	my Mail::SPF::Iterator $self = shift;
	my $data = shift;

	my (@mech,$redirect,$explain);
	for ( split( ' ', $data )) {
		my ($qual,$mech,$mod,$arg) = m{^(?:
			([~\-+?]?) # Qualifier
			(all|ip[46]|a|mx|ptr|exists|include)   # Mechanism
			|(redirect|exp)   # Modifier
			|[a-zA-Z][\w.\-]*=  # unknown modifier + '='
		)(.*)  # Arguments
		$}x
			or die "bad SPF part: $_\n";

		if ( $mech ) {
			$qual = $qual2rv{ $qual || '+' };

			if ( $mech eq 'all' ) {
				die "no arguments allowed with mechanism 'all': '$_'\n"
					if $arg ne '';
				push @mech, [ \&_mech_all, $qual ]

			} elsif ( $mech eq 'ip4' ) {
				my ($ip,$plen) =
					$arg =~m{^:(\d+\.\d+\.\d+\.\d+)(?:/([1-9]\d*|0))?$}
					or die "bad argument for mechanism 'ip4' in '$_'\n";
				$plen = 32 if ! defined $plen;
				$plen>32 and die "invalid prefix len >32 in '$_'\n";
				eval { $ip = inet_aton( $ip ) }
					or die "bad ip '$ip' in '$_'\n";
				next if ! $self->{clientip4}; # don't use for IP6
				push @mech, [ \&_mech_ip4, $qual, $ip,$plen ];

			} elsif ( $mech eq 'ip6' ) {
				my ($ip,$plen) =
					$arg =~m{^:([\da-fA-F:\.]+)(?:/([1-9]\d*|0))?$}
					or die "bad argument for mechanism 'ip6' in '$_'\n";
				$plen = 128 if ! defined $plen;
				$plen>128 and die "invalid prefix len >128 in '$_'\n";
				eval { $ip = inet_pton( AF_INET6,$ip ) }
					or die "bad ip '$ip' in '$_'\n"
					if $can_ip6;
				next if ! $self->{clientip6}; # don't use for IP4
				push @mech, [ \&_mech_ip6, $qual, $ip,$plen ];

			} elsif ( $mech eq 'a' or $mech eq 'mx' ) {
				$arg ||= '';
				my ($domain,$plen4,$plen6) =
					$arg =~m{^(?::(.+?))?(?:/(?:([1-9]\d*|0)|/([1-9]\d*|0)))?$}
					or die "bad argument for mechanism '$mech' in '$_'\n";
				if ( defined $plen4 ) {
					$plen4>32 and die "invalid prefix len >32 in '$_'\n";
				} elsif ( defined $plen6 ) {
					$plen6>128 and die "invalid prefix len >128 in '$_'\n";
				}
				if ( $self->{clientip4} ) {
					# ignore IP6 checks when we are using IP4
					next if defined $plen6;
					$plen4 = 32 if ! defined $plen4;
				} else {
					# ignore IP4 checks when we are using IP6
					next if defined $plen4;
					$plen6 = 128 if ! defined $plen6;
				}
				if ( ! $domain ) {
					$domain = $self->{domain};
				} else {
					if ( my @err = _check_macro_domain($domain)) {
						die(($err[2]->{problem}||"Invalid domain name")."\n");
					}
					$domain = $self->_macro_expand($domain);
				}
				my $sub = $mech eq 'a' ? \&_mech_a : \&_mech_mx;
				push @mech, [ \&_resolve_macro_p, $domain ] if ref($domain);
				push @mech, [ $sub, $qual, $domain,
					$self->{clientip4} ? $plen4:$plen6 ];

			} elsif ( $mech eq 'ptr' ) {
				my ($domain) = ( $arg || '' )=~m{^(?::([^/]+))?$}
					or die "bad argument for mechanism '$mech' in '$_'\n";
				$domain = $domain
					? $self->_macro_expand($domain)
					: $self->{domain};
				push @mech, [ \&_resolve_macro_p, $domain ] if ref($domain);
				push @mech, [ \&_mech_ptr, $qual, $domain ];

			} elsif ( $mech eq 'exists' ) {
				my ($domain) = ( $arg || '' )=~m{^:([^/]+)$}
					or die "bad argument for mechanism '$mech' in '$_'\n";
				$domain = $self->_macro_expand($domain);
				push @mech, [ \&_resolve_macro_p, $domain ] if ref($domain);
				push @mech, [ \&_mech_exists, $qual, $domain ];

			} elsif ( $mech eq 'include' ) {
				my ($domain) = ( $arg || '' )=~m{^:([^/]+)$}
					or die "bad argument for mechanism '$mech' in '$_'\n";
				$domain = $self->_macro_expand($domain);
				push @mech, [ \&_resolve_macro_p, $domain ] if ref($domain);
				push @mech, [ \&_mech_include, $qual, $domain ];

			} else {
				die "unhandled mechanism '$mech'\n"
			}

		} elsif ( $mod ) {
			# multiple redirect or explain will be considered an error
			if ( $mod eq 'redirect' ) {
				die "redirect was specified more than once\n" if $redirect;
				my ($domain) = ( $arg || '' )=~m{^=([^/]+)$}
					or die "bad argument for modifier '$mod' in '$_'\n";
				if ( my @err = _check_macro_domain($domain)) {
					die(( $err[2]->{problem} || "Invalid domain name" )."\n" );
				}
				$redirect = $self->_macro_expand($domain);

			} elsif ( $mod eq 'exp' ) {
				die "$explain was specified more than once\n" if $explain;
				my ($domain) = ( $arg || '' )=~m{^=([^/]+)$}
					or die "bad argument for modifier '$mod' in '$_'\n";
				if ( my @err = _check_macro_domain($domain)) {
					die(( $err[2]->{problem} || "Invalid domain name" )."\n" );
				}
				$explain = $self->_macro_expand($domain);

			} elsif ( $mod ) {
				die "unhandled modifier '$mod'\n"
			}
		} else {
			# unknown modifier - check if arg is valid macro-string
			# (will die() on error) but ignore modifier
			$self->_macro_expand($arg || '');
		}
	}
	$self->{mech} = \@mech;
	$self->{explain} = $explain;
	$self->{redirect} = $redirect;
	return 1;
}

############################################################################
# handles mechanism 'all'
# matches all time
############################################################################
sub _mech_all {
	my Mail::SPF::Iterator $self = shift;
	my $qual = shift;
	DEBUG( "match mech all with qual=$qual" );
	return ( $qual,'matches default', { mechanism => 'all' });
}

############################################################################
# handle mechanism 'ip4'
# matches if clients IP4 address is in ip/mask
############################################################################
sub _mech_ip4 {
	my Mail::SPF::Iterator $self = shift;
	my ($qual,$ip,$plen) = @_;
	defined $self->{clientip4} or return (); # ignore rule, no IP4 address
	if ( ($self->{clientip4} & $mask4[$plen]) eq ($ip & $mask4[$plen]) ) {
		# rules matches
		DEBUG( "match mech ip4:".inet_ntoa($ip)."/$plen with qual=$qual" );
		return ($qual,"matches ip4:".inet_ntoa($ip)."/$plen",
			{ mechanism => 'ip4' } )
	}
	DEBUG( "no match mech ip4:".inet_ntoa($ip)."/$plen" );
	return (); # ignore, no match
}

############################################################################
# handle mechanism 'ip6'
# matches if clients IP6 address is in ip/mask
############################################################################
sub _mech_ip6 {
	my Mail::SPF::Iterator $self = shift;
	my ($qual,$ip,$plen) = @_;
	defined $self->{clientip6} or return (); # ignore rule, no IP6 address
	if ( ($self->{clientip6} & $mask6[$plen]) eq ($ip & $mask6[$plen])) {
		# rules matches
		DEBUG( "match mech ip6:".inet_ntop(AF_INET6,$ip)."/$plen with qual=$qual" );
		return ($qual,"matches ip6:".inet_ntop(AF_INET6,$ip)."/$plen",
			{ mechanism => 'ip6' } )
	}
	DEBUG( "no match ip6:".inet_ntop(AF_INET6,$ip)."/$plen" );
	return (); # ignore, no match
}

############################################################################
# handle mechanism 'a'
# check if one of the A/AAAA records for $domain resolves to
# clientip/plen,
############################################################################
sub _mech_a {
	my Mail::SPF::Iterator $self = shift;
	my ($qual,$domain,$plen) = @_;
	$domain = $domain->{expanded} if ref $domain;
	DEBUG( "check mech a:$domain/$plen with qual=$qual" );
	if ( my @err = _check_domain($domain, "a:$domain/$plen")) {
		# spec is not clear here:
		# variante1: no match on invalid domain name -> return
		# variante2: propagate err -> return @err
		# we use variante2 for now
		DEBUG( "no match mech a:$domain/$plen - @err" );
		return @err;
	}

	return ( SPF_PermError, "",
		{ problem => "Number of DNS mechanism exceeded" })
		if --$self->{limit_dns_mech} < 0;

	my $typ = $self->{clientip4} ? 'A':'AAAA';
	$self->{cb} = [ \&_got_A, $qual,$plen,[ $domain ],'a' ];
	return scalar(Net::DNS::Packet->new( $domain, $typ,'IN' ));
}

############################################################################
# this is used in _mech_a and in _mech_mx if the address for an MX is not
# sent inside the additional data
# in the case of MX $names might contain more than one name to resolve, it
# will try to resolve names to addresses and to match them until @$names
# is empty
############################################################################
sub _got_A {
	my Mail::SPF::Iterator $self = shift;
	my ($qtype,$rcode,$ans,$add,$qual,$plen,$names,$mech) = @_;
	my $domain = shift(@$names);

	DEBUG( "got response to $qtype for $domain: $rcode" );
	if ( $rcode eq 'NXDOMAIN' ) {
		DEBUG( "no match mech a:$domain/$plen - $rcode" );
		# no records found
	} elsif ( $rcode ne 'NOERROR' ) {
		DEBUG( "temperror mech a:$domain/$plen - $rcode" );
		return ( SPF_TempError,
			"getting $qtype for $domain",
			{ problem => "error resolving $domain" }
		);
	}

	my @addr = map { $_->address } @$ans;
	return _check_A_match($self,$qual,$domain,$plen,\@addr,$names,$mech);
}

sub _check_A_match {
	my Mail::SPF::Iterator $self = shift;
	my ($qual,$domain,$plen,$addr,$names,$mech) = @_;

	# process all found addresses
	if ( $self->{clientip4} ) {
		$plen = 32 if ! defined $plen;
		my $mask = $mask4[$plen];
		for my $addr (@$addr) {
			DEBUG( "check a:$domain($addr)/$plen for mech $mech" );
			my $packed = $addr=~m{^[\d.]+$} && eval { inet_aton($addr) }
				or return ( SPF_TempError,
					"getting A for $domain",
					{ problem => "bad address in A record" }
				);

			if ( ($packed & $mask) eq  ($self->{clientip4} & $mask) ) {
				# match!
				DEBUG( "match mech a:.../$plen for mech $mech with qual $qual" );
				return ($qual,"matches domain: $domain/$plen with IP4 $addr",
					{ mechanism => $mech })
			}
		}
	} else { # AAAA
		$plen = 128 if ! defined $plen;
		my $mask = $mask6[$plen];
		for my $addr (@$addr) {
			DEBUG( "check a:$domain($addr)//$plen for mech $mech" );
			my $packed = eval { inet_pton(AF_INET6,$addr) }
				or return ( SPF_TempError,
					"getting AAAA for $domain",
					{ problem => "bad address in AAAA record" }
				);
			if ( ($packed & $mask) eq ($self->{clientip6} & $mask) ) {
				# match!
				DEBUG( "match mech a:...//$plen for mech $mech with qual $qual" );
				return ($qual,"matches domain: $domain//$plen with IP6 $addr",
					{ mechanism => $mech })
			}
		}
	}

	# no match yet, can we resolve another name?
	if ( @$names ) {
		my $typ = $self->{clientip4} ? 'A':'AAAA';
		DEBUG( "check mech a:$names->[0]/$plen for mech $mech with qual $qual" );
		$self->{cb} = [ \&_got_A, $qual,$plen,$names,$mech ];
		return scalar(Net::DNS::Packet->new( $names->[0], $typ,'IN' ));
	}

	# finally no match
	DEBUG( "no match mech $mech:$domain/$plen" );
	return;
}



############################################################################
# handle mechanism 'mx'
# similar to mech 'a', we expect the A/AAAA records for the MX in the
# additional section of the DNS response
############################################################################
sub _mech_mx {
	my Mail::SPF::Iterator $self = shift;
	my ($qual,$domain,$plen) = @_;
	$domain = $domain->{expanded} if ref $domain;
	if ( my @err = _check_domain($domain,
		"mx:$domain".( defined $plen ? "/$plen":"" ))) {
		DEBUG( "no mech mx:$domain/$plen - @err" );
		return @err
	}

	return ( SPF_PermError, "",
		{ problem => "Number of DNS mechanism exceeded" })
		if --$self->{limit_dns_mech} < 0;

	$self->{cb} = [ \&_got_MX,$qual,$domain,$plen ];
	return scalar(Net::DNS::Packet->new( $domain, 'MX','IN' ));
}

sub _got_MX {
	my Mail::SPF::Iterator $self = shift;
	my ($qtype,$rcode,$ans,$add,$qual,$domain,$plen) = @_;

	if ( $rcode eq 'NXDOMAIN' ) {
		DEBUG( "no match mech mx:$domain/$plen - $rcode" );
		# no records found
	} elsif ( $rcode ne 'NOERROR' ) {
		DEBUG( "no match mech mx:$domain/$plen - $rcode" );
		return ( SPF_TempError,
			"getting MX form $domain",
			{ problem => "error resolving $domain" }
		);
	} elsif ( ! @$ans ) {
		DEBUG( "no match mech mx:$domain/$plen - no MX records" );
		return; # domain has no MX -> no match
	}

	# all MX, with best (lowest) preference first
	my @mx = map { $_->[0] }
		sort { $a->[1] <=> $b->[1] }
		map { [ $_->exchange, $_->preference ] }
		@$ans;
	my %mx = map { $_ => [] } @mx;

	# try to find A|AAAA records in additional data
	my $atyp = $self->{clientip4} ? 'A':'AAAA';
	for my $rr (@$add) {
		if ( $rr->type eq $atyp && exists $mx{$rr->name} ) {
			push @{$mx{$rr->name}},$rr->address;
		}
	}
	DEBUG( "found mx for $domain: ".join( " ",
		map { $mx{$_} ? "$_(".join(",",@{$mx{$_}}).")" : $_ } @mx ));

	# remove from @mx where I've found addresses
	@mx = grep { ! @{$mx{$_}} } @mx;
	# limit the Rest to 10 records (rfc4408,10.1)
	splice(@mx,10) if @mx>10;

	my @addr = map { @$_ } values %mx;
	return _check_A_match( $self,$qual,"(mx)".$domain,$plen,\@addr,\@mx,'mx');
}

############################################################################
# handle mechanis 'exists'
# just check, if I get any A record for the domain (lookup for A even if
# I use IP6 - this is RBL style)
############################################################################
sub _mech_exists {
	my Mail::SPF::Iterator $self = shift;
	my ($qual,$domain) = @_;
	$domain = $domain->{expanded} if ref $domain;
	if ( my @err = _check_domain($domain, "exists:$domain" )) {
		DEBUG( "no match mech exists:$domain - @err" );
		return @err
	}

	return ( SPF_PermError, "",
		{ problem => "Number of DNS mechanism exceeded" })
		if --$self->{limit_dns_mech} < 0;

	$self->{cb} = [ \&_got_A_exists,$qual,$domain ];
	return scalar(Net::DNS::Packet->new( $domain, 'A','IN' ));
}

sub _got_A_exists {
	my Mail::SPF::Iterator $self = shift;
	my ($qtype,$rcode,$ans,$add,$qual,$domain) = @_;

	if ( $rcode ne 'NOERROR' ) {
		DEBUG( "no match mech exists:$domain - $rcode" );
		return;
	} elsif ( ! @$ans ) {
		DEBUG( "no match mech exists:$domain - no A records" );
		return;
	}
	DEBUG( "match mech exists:$domain with qual $qual" );
	return ($qual,"domain $domain exists", { mechanism => 'exists' } )
}



############################################################################
# PTR
# this is the most complex and most expensive mechanism:
# - first get domains from PTR records for IP (clientip4|clientip6)
# - filter for domains which match $domain (because only these are interesting
#   for matching)
# - then verify the domains, if they point back to the IP by doing A|AAAA
#   lookups until one domain can be validated
############################################################################
sub _mech_ptr {
	my Mail::SPF::Iterator $self = shift;
	my ($qual,$domain) = @_;
	$domain = $domain->{expanded} if ref $domain;
	if ( my @err = _check_domain($domain, "ptr:$domain" )) {
		DEBUG( "no match mech ptr:$domain - @err" );
		return @err
	}

	return ( SPF_PermError, "",
		{ problem => "Number of DNS mechanism exceeded" })
		if --$self->{limit_dns_mech} < 0;

	my $ip = $self->{clientip4} || $self->{clientip6};
	if ( exists $self->{validated}{$ip}{$domain} ) {
		# already checked
		if ( ! $self->{validated}{$ip}{$domain} ) {
			# could not be validated
			DEBUG( "no match mech ptr:$domain - cannot validate $ip/$domain" );
			return; # ignore
		} else {
			DEBUG( "match mech ptr:$domain with qual $qual" );
			return ($qual,"$domain validated" );
		}
	}

	my $query;
	if ( $self->{clientip4} ) {
		$query = join( '.', reverse split( m/\./,
			inet_ntoa($self->{clientip4}) ))
			.'.in-addr.arpa'
	} else {
		$query = join( '.', split( //,
			reverse unpack("H*",$self->{clientip6}) ))
			.'.ip6.arpa';
	}

	$self->{cb} = [ \&_got_PTR,$qual,$query,$domain ];
	return scalar(Net::DNS::Packet->new( $query, 'PTR','IN' ));
}

sub _got_PTR {
	my Mail::SPF::Iterator $self = shift;
	my ($qtype,$rcode,$ans,$add,$qual,$query,$domain) = @_;

	# ignore mech if it can not be validated
	$rcode eq 'NOERROR' or do {
		DEBUG( "no match mech ptr:$domain - $rcode" );
		return;
	};
	my @names = map { $_->ptrdname } @$ans or do {
		DEBUG( "no match mech ptr:$domain - no names in PTR lookup" );
		return;
	};

	# strip records, which do not end in $domain
	@names = grep { $_ eq $domain || m{\.\Q$domain\E$} } @names;
	if ( ! @names ) {
		DEBUG( "no match mech ptr:$domain - no names in PTR lookup match $domain" );
		# return if no matches inside $domain
		return;
	}

	# limit to no more then 10 names (see RFC4408, 10.1)
	splice(@names,10) if @names>10;

	# validate the rest by looking up the IP and verifying it
	# with the original IP (clientip)
	my $typ = $self->{clientip4} ? 'A':'AAAA';

	$self->{cb} = [ \&_got_A_ptr, $qual,\@names ];
	return scalar(Net::DNS::Packet->new( $names[0], $typ,'IN' ));
}

sub _got_A_ptr {
	my Mail::SPF::Iterator $self = shift;
	my ($qtype,$rcode,$ans,$add,$qual,$names) = @_;

	for my $dummy ( $rcode eq 'NOERROR' ? (1):() ) {
		@$ans or last; # no addr for domain? - try next
		my @addr = map { $_->address } @$ans;

		# check if @addr contains clientip
		my ($match,$ip);
		if ( $ip = $self->{clientip4} ) {
			for(@addr) {
				m{^[\d\.]+$} or next;
				eval { inet_aton($_) } eq $ip or next;
				$match = 1;
				last;
			}
		} else {
			$ip = $self->{clientip6};
			for(@addr) {
				eval { inet_pton(AF_INET6,$_) } eq $ip or next;
				$match = 1;
				last;
			}
		}

		# cache verification status
		$self->{validated}{$ip}{$names->[0]} = $match;

		# return $qual if we have verified the ptr
		if ($match) {
			DEBUG( "match mech ptr:... with qual $qual" );
			return ( $qual,"verified clientip with ptr", { mechanism => 'ptr' })
		}
	}

	# try next
	shift @$names;
	@$names or do {
		# no next
		DEBUG( "no match mech ptr:... - no more names for clientip" );
		return;
	};

	# cb stays the same
	return scalar(Net::DNS::Packet->new( $names->[0], $qtype,'IN' ));
}


############################################################################
# mechanism include
# include SPF from other domain, propagate errors and consider Pass
# from this inner SPF as match for the include mechanism
############################################################################
sub _mech_include {
	my Mail::SPF::Iterator $self = shift;
	my ($qual,$domain) = @_;
	$domain = $domain->{expanded} if ref $domain;
	if ( my @err = _check_domain($domain, "include:$domain" )) {
		DEBUG( "failed mech include:$domain - @err" );
		return @err
	}

	DEBUG( "mech include:$domain with qual=$qual" );

	return ( SPF_PermError, "",
		{ problem => "Number of DNS mechanism exceeded" })
		if --$self->{limit_dns_mech} < 0;

	# push and reset current domain and SPF record
	push @{$self->{include_stack}}, {
		domain   => $self->{domain},
		mech     => $self->{mech},
		explain  => $self->{explain},
		redirect => $self->{redirect},
		qual     => $qual,
	};
	$self->{domain}   = $domain;
	$self->{mech}     = [];
	$self->{explain}  = undef;
	$self->{redirect} = undef;

	# start with new SPF record
	return $self->_query_txt_spf;
}


############################################################################
# create explain message from TXT record
############################################################################
sub _got_TXT_exp {
	my Mail::SPF::Iterator $self = shift;
	my ($qtype,$rcode,$ans,$add) = @_;
	my $final = $self->{result};

	if ( $rcode ne 'NOERROR' ) {
		DEBUG( "DNS error for exp TXT lookup" );
		# just return the final rv
		return @$final;
	}

	my ($txtdata,$t2) = grep { length } map { $_->txtdata } @$ans;;
	if ( $t2 ) {
		# only one record should be returned
		DEBUG( "got more than one TXT -> error" );
		return @$final;
	} elsif ( ! $txtdata ) {
		DEBUG( "no text in TXT for explain" );
		return @$final;
	}

	DEBUG( "got TXT $txtdata" );

	# valid TXT record found -> expand macros
	my $exp = eval { $self->_macro_expand( $txtdata,'exp' ) };
	if ($@) {
		DEBUG( "macro expansion of '$txtdata' failed: $@" );
		return @$final;
	}

	# explain
	if (ref $exp) {
		if ( my @xrv = $self->_resolve_macro_p($exp)) {
			# we need to do more DNS lookups for resolving %{p} macros
			DEBUG( "need to resolve %{p} in $exp->{macro}" );
			$final->[4] = $exp;
			return @xrv;
		}
		$exp = $exp->{expanded};
	}

	# result should be limited to US-ASCII!
	# further limit to printable chars
	$final->[3] = $exp if $exp !~m{[\x00-\x1f\x7e-\xff]};

	return @$final;
}

############################################################################
# expand Macros
############################################################################
sub _macro_expand {
	my Mail::SPF::Iterator $self = shift;
	my ($domain,$explain) = @_;
	my $new_domain = '';
	my $mchars = $explain ? qr{[slodipvhcrt]}i : qr{[slodipvh]}i;
	my $need_validated;
	#DEBUG( Carp::longmess("no domain" )) if ! $domain;
	#DEBUG( "domain=$domain" );
	while ( $domain =~ m{\G (?:
		([^%]+) |                                   # text
		%(?:
			([%_\-]) |                              # char: %_, %-, %%
			{
				# macro: l1r+- ->  (l)(1)(r)(+-)
				($mchars) (\d*)(r?) ([.\-+,/_=]*)
			} |
			(.|$)                                   # bad char
		))}xg ) {
		my ($text,$char,$macro,$macro_n,$macro_r,$macro_delim,$bad)
			= ($1,$2,$3,$4,$5,$6,$7);

		if ( defined $text ) {
			$new_domain .= $text;

		} elsif ( defined $char ) {
			$new_domain .=
				$char eq '%' ? '%' :
				$char eq '_' ? ' ' :
				'%20'

		} elsif ( $macro ) {
			$macro_delim ||= '.';
			my $imacro = lc($macro);
			my $expand =
				$imacro eq 's' ? $self->{sender} :
				$imacro eq 'l' ?  $self->{sender} =~m{^([^@]+)\@}
					? $1 : 'postmaster' :
				$imacro eq 'o' ? $self->{sender} =~m{\@(.*)}
					? $1 : $self->{sender} :
				$imacro eq 'd' ? $self->{domain} :
				$imacro eq 'i' ? $self->{clientip4} ?
					inet_ntoa($self->{clientip4}) :
					join('.',map { uc } split(//,
						unpack( "H*",$self->{clientip6}))) :
				$imacro eq 'v' ? $self->{clientip4} ? 'in-addr' : 'ip6':
				$imacro eq 'h' ? $self->{helo} :
				$imacro eq 'c' ? $self->{clientip4} ?
					inet_ntoa($self->{clientip4}) :
					inet_ntop(AF_INET6,$self->{clientip6}) :
				$imacro eq 'r' ? $self->{myname} || 'unknown' :
				$imacro eq 't' ? time() :
				$imacro eq 'p' ? do {
					my $ip = $self->{clientip4} || $self->{clientip6};
					my $v = $self->{validated}{$ip};
					my $d = $self->{domain};
					if ( ! $v ) {
						# nothing validated pointing to IP
						$need_validated = { ip => $ip, domain => $d };
						'unknown'
					} elsif ( $v->{$d} ) {
						# <domain> itself is validated
						$d;
					} elsif ( my @xd = grep { $v->{$_} } keys %$v ) {
						if ( my @sd = grep { m{\.\Q$d\E$} } @xd ) {
							# subdomain if <domain> is validated
							$sd[0]
						} else {
							# any other domain pointing to IP
							$xd[0]
						}
					} else {
						'unknown'
					}
				} :
				die "unknown macro $macro\n";

			my $rx = eval "qr{[$macro_delim]}";
			my @parts = split( $rx, $expand );
			@parts = reverse @parts if $macro_r;
			if ( length $macro_n ) {
				die "bad macro definition '$domain'\n"
					if ! $macro_n; # must be != 0
				@parts = splice( @parts,-$macro_n ) if @parts>$macro_n;
			}
			if ( $imacro ne $macro ) {
				# upper case - URI escape
				@parts = map { uri_escape($_) } @parts;
			}
			$new_domain .= join('.',@parts);

		} else {
			die "bad macro definition '$domain'\n";
		}
	}

	if ( ! $explain ) {
		# should be less than 253 bytes
		while ( length($new_domain)>253 ) {
			$new_domain =~s{^[^.]*\.}{} or last;
		}
		$new_domain = '' if length($new_domain)>253;
	}

	if ( $need_validated ) {
		return { expanded => $new_domain, %$need_validated, macro => $domain }
	} else {
		return $new_domain;
	}
}

############################################################################
# resolve macro %{p}, e.g. find validated domain name for IP and replace
# %{p} with it. This has many thing similar with the ptr: method
############################################################################
sub _resolve_macro_p {
	my Mail::SPF::Iterator $self = shift;
	my $rec = shift;
	my $ip = ref($rec) && $rec->{ip} or return; # nothing to resolve

	# could it already be resolved w/o further lookups?
	my $d = eval { $self->_macro_expand( $rec->{macro} ) };
	if ( ! ref $d ) {
		%$rec = ( expanded => $d ) if ! $@;
		return;
	}

	my $query;
	if ( length($ip) == 4 ) {
		$query = join( '.', reverse split( m/\./,
			inet_ntoa($ip) )) .'.in-addr.arpa'
	} else {
		$query = join( '.', split( //,
			reverse unpack("H*",$ip) )) .'.ip6.arpa';
	}

	$self->{cb} = [ \&_validate_got_PTR, $rec ];
	return scalar(Net::DNS::Packet->new( $query, 'PTR','IN' ));
}

sub _validate_got_PTR {
	my Mail::SPF::Iterator $self = shift;
	my ($qtype,$rcode,$ans,$add,$rec ) = @_;

	# no validation possible if no records
	return if $rcode ne 'NOERROR' or ! @$ans;

	my @names = map { lc($_->ptrdname) } @$ans;

	# prefer records, which are $domain or end in $domain
	if ( my $domain = $rec->{domain} ) {
		unshift @names, grep { $_ eq $domain } @names;
		unshift @names, grep { m{\.\Q$domain\E$} } @names;
		{ my %n; @names = grep { !$n{$_}++ } @names } # uniq
	}

	# limit to no more then 10 names (RFC4408, 10.1)
	splice(@names,10) if @names>10;

	# validate the rest by looking up the IP and verifying it
	# with the original IP (clientip)
	my $typ = length($rec->{ip}) == 4 ? 'A':'AAAA';

	$self->{cb} = [ \&_validate_got_A_ptr, $rec,\@names ];
	return scalar(Net::DNS::Packet->new( $names[0], $typ,'IN' ));
}

sub _validate_got_A_ptr {
	my Mail::SPF::Iterator $self = shift;
	my ($qtype,$rcode,$ans,$add,$rec,$names) = @_;

	if ( $rcode eq 'NOERROR' ) {
		my @addr = map { $_->address } @$ans or do {
			# no addr for domain? -> ignore - maybe
			# the domain only provides the other kind of records?
			return;
		};

		# check if @addr contains clientip
		my $match;
		my $ip = $rec->{ip};
		if ( length($ip) == 4 ) {
			for(@addr) {
				m{^[\d\.]+$} or next;
				eval { inet_aton($_) } eq $ip or next;
				$match = 1;
				last;
			}
		} else {
			for(@addr) {
				eval { inet_pton(AF_INET6,$_) } eq $ip or next;
				$match = 1;
				last;
			}
		}

		# cache verification status
		$self->{validated}{$ip}{$names->[0]} = $match;

		# expand macro if we have verified the ptr
		if ( $match ) {
			if ( my $t = eval { $self->_macro_expand( $rec->{macro} ) }) {
				%$rec = ( expanded => $t );
			}
			return;
		}
	}

	# try next
	shift @$names;
	@$names or return; # no next

	# cb stays the same
	return scalar(Net::DNS::Packet->new( $names->[0], $qtype,'IN' ));
}


1;