package Mail::Audit::Bounce;
use Mail::Audit;
use vars qw(@VERSION);
$VERSION = '0.01';
1;

=head 1

Mail::Audit::Bounce - Recognize a mail as a bounce mail

=cut

package Mail::Audit;
use strict;

my $content_type = qr(report-type=delivery-status);
my $sender       = qr(Mail Delivery Subsystem <MAILER-DAEMON\@);

my @headers = (
  'X-Virus-Found'        => [ qr/./, "Virus found"],        # header m
+ust be present
  'X-Tnz-Problem-Type'        => [ qr/^40$/, "Virus found"],
  'X-Failed-Recipients'        => [ qr/./, undef],
  'Auto-Submitted'        => [ qr<auto-generated \(failure\)>,undef],
  'Content-Type'        => [ qr<multipart/report; report-type=delivery
+-status;>ism,undef],
  'Content-Type'        => [ qr<multipart/report; report-type=(["'])de
+livery-status\1;>ism,undef],
  'Received'            => [ qr<\(qmail \d+ invoked for bounce\);>sm, 
+undef],
);

sub __scan_delivery_report {
  my ($self) = @_;
  my @result;

  my @body;
  for my $line (@{$self->body}) {
    push @body, split /\n/, $line;
  };

  my $i = 0;
  while ($i < @headers) {
    my ($header,$r) = (@headers[$i,$i+1]);
    my ($content,$reason) = @$r;
    my @h = ($self->head->get($header), map { /^$header: (.*)$/ ? $1 :
+ () } @body);
    for my $line (@h) {
      push @result, $reason
        if ($line =~ $content);
    };
    $i += 2;
  };

  @result;
};

sub __mime_parts {
  my ($self,$content_type) = @_;
  grep { ($_->head->get('Content-Type')||"") =~ /$content_type/i } ($s
+elf->parts)
};

sub is_bounce {
  my ($self) = @_;
  my @parts;
  my @reasons;

  push @reasons, "mailer daemon"
    if $self->from =~ $sender;
  my $i = 0;
  while ($i < @headers) {
    my ($header,$r) = (@headers[$i,$i+1]);
    my ($content,$reason) = @$r;
    my @h = $self->head->get($header);
    for my $line (@h) {
      push @reasons, $reason
        if ($line =~ $content);
    };
    $i += 2;
  };

  if ($self->is_mime) {
    @parts = $self->parts;
    foreach my $part ($self->__mime_parts('message/delivery-status')) 
+{
      push @reasons, __scan_delivery_report($part)
    };
  };

  if (@reasons) {
    @reasons = grep { defined $_ } @reasons;
    @reasons = "unknown" unless @reasons;
  };

  @reasons;
};

=head2 C<< $message->original_message_id >>

This tries to find the original message id for a bounced
message. C<< is_bounce >> should be true before you ask
for the original message id.

It returns a list of candidates for the original message id.

=cut

sub original_message_id {
  my ($self) = @_;
  my %result;

  if ($self->is_mime) {
    # let's hope for the original message in
    # the 'message/rfc822' part
    foreach my $part ($self->__mime_parts('message/rfc822'),$self->__m
+ime_parts('text/rfc822-headers')) {
      for (map { /^Message-Id: (.*)$/i ? $1 : () } @{ $part->body }) {
        $result{$_} = 1
      };
    };
  } else {
    for (map { /^Message-Id: (.*)$/i ? $1 : () } @{ $self->body }) {
      $result{$_} = 1
    };
  };

  keys %result;
};
[download]

In the module, I consider stuff a bounce that:

• Comes from MAILER-DAEMON@* or
• Contains one of the above listed headers with a value matching the regular expression

The method of collecting and checking the headers seems clumsy and inflexible to me, but except for InterScan NT virus bounces, it has proven to be effective for the kinds of bounces I get. If anyone has a more elegant method, it is welcomed.

Possibly, some SpamAssassin rules could also do the same for me, but I haven't gotten around installing and using it - I'm still using my hand-made mail sorting script as my first line of defense.