view release on metacpan or  search on metacpan

lib/Mail/DMARC/Iterator.pm  view on Meta::CPAN

		# skip quoted text
		m{\G (?:[^"\\]+|\\.)* \"}xgc or last; # missing final \"
		pop @state;
	    } elsif ($state[-1] eq '(') {
		# skip comments (can be nested)
		m{\G .*? ([()]) }xsgc or last; # missing final ')'
		if ($1 eq ')') {
		    pop @state;
		} else {
		    push @state,'('
		}
	    }
	}
	$DEBUG && debug("extract: $_ -> ".join(" ",sort keys %domains));
	return sort keys %domains;
    }
}

{
    # Parse Received-SPF header into (result,\%hash).
    my %res;
    $res{ lc($_) } = $_ for(SPF_Pass, SPF_Fail, SPF_SoftFail, SPF_Neutral,
	SPF_None, SPF_TempError, SPF_PermError);
    my $res = join("|",keys %res);
    $res = qr{$res}i;
    my $fws = qr{(?:[ \t]*\r?\n)?[ \t]+};
    my $key = qr{\w[\w\-]*};
    my $atext = qr{[0-9a-zA-Z!#$%&'*+\-/=?^_`{|}~]+};
    my $dotatom = qr{$atext(?:\.$atext)*};
    my $qstring = qr{"(?:[^"\\]+|\\.)*"};
    my $val = qr{$dotatom|$qstring};

    sub _parse_spfreceived {
	local $_ = shift;
	m{\G($res)\s+}igc or return;
	my $result = $res{ lc($1) };
	my %hash;
	my $comment;
	while (1) {
	    if ($comment) {
		last if ! m{\G[^()]*([()])\s*}gc; # no end of comment found
		$comment += $1 eq '(' ? +1:-1;
	    } elsif (m{\G($key)$fws?=$fws?($val)\s*(;\s*)?}gc) {
		my ($k,$v,$delim) = ($1,$2,$3);
		$v =~s{\\(.)}{$1}g if $v =~s{\A\"(.*)\"\z}{$1};
		$hash{$k} = $v;
		last if ! $delim; # no delimeter-> end
	    } elsif (!%hash && !defined $comment && m{\G\(}gc) {
		$comment++;
	    } else {
		last
	    }
	}
	return ($result,\%hash);
    }
}

{
    # Define function organizational_domain based on which package we have to
    # calculate the public suffix.
    if (eval { require IO::Socket::SSL::PublicSuffix }) {
	my $ps = IO::Socket::SSL::PublicSuffix->default;
	*organizational_domain = sub {
	    return $ps->public_suffix($_[0],1) || $_[0];
	};
    } elsif (eval { require Domain::PublicSuffix }) {
	my $ps = Domain::PublicSuffix->new;
	*organizational_domain = sub {
	    return $ps->get_root_domain($_[0]) || $_[0];
	};

    } elsif (eval { require Mozilla::PublicSuffix }) {
	*organizational_domain = sub {
	    my $domain = shift;
	    if (my $suffix = Mozilla::PublicSuffix::public_suffix($domain)) {
		return $1 if $domain =~m{([^\.]+\.\Q$suffix\E$)}i;
	    }
	    return $domain;
	}
    } else {
	die "failed to find any package for calculating the public suffix";
    }
}

1;

__END__

=head1 NAME

Mail::DMARC::Iterator - Iterativ DMARC validation for mails.

=head1 SYNOPSIS

    use Mail::DMARC::Iterator;
    use Net::DNS::Resolver;

    my $resolver = Net::DNS::Resolver->new;
    my $dmarc = Mail::DMARC::Iterator->new(

	# data from SMTP dialog - used for SPF
	ip => '10.11.12.13',
	mailfrom => 'foo@example.com',
	helo => 'mx.example.com',

	# alternatively add predefined results from your own SPF validation
	# spf_result => [ 'pass',undef, { 'envelope-from' => ... } ]

	# or set to undef so that it tries to use Received-SPF header fields
	# spf_result => undef,

	# you can optionally use a global DNS cache
	# dnscache => \%global_cache
    );

    open( my $fh,'<','mail.eml');      # open the file
    my ($result,@todo) = $dmarc->next; # initial result

    while (!defined $result && @todo) {
	my $todo = shift(@todo);
	if (!ref($todo)) {
	    # no reference - indicator that we need more mail data