File Coverage

blib/lib/Email/ARF/Report.pm

Criterion	Covered	Total	%
statement	75	75	100.0
branch	20	26	76.9
condition	8	15	53.3
subroutine	20	20	100.0
pod	10	10	100.0
total	133	146	91.1

use strict;
use warnings;
package Email::ARF::Report;
{
  $Email::ARF::Report::VERSION = '0.010';
}
# ABSTRACT: interpret Abuse Reporting Format (ARF) messages

use Carp ();
use Email::MIME 1.900 (); # ->subtypes
use Email::MIME::ContentType 1.016 (); # type/subtype
use Scalar::Util ();
use Params::Util qw(_INSTANCE);


sub new {
  my ($class, $source) = @_;

  Carp::croak "no report source provided" unless $source;

  my $mime = Scalar::Util::blessed $source
           ? $source
           : Email::MIME->new($source);

  Carp::croak "ARF report source could not be interpreted as MIME message"
    unless eval { $mime->isa('Email::MIME') };

  my $ct_header = $mime->content_type;
  my $ct = Email::MIME::ContentType::parse_content_type($ct_header);

  Carp::croak "non-ARF content type '$ct_header' on ARF report source"
    unless $ct->{type}  eq 'multipart'
    and    $ct->{subtype} eq 'report'
    and    $ct->{attributes}{'report-type'} eq 'feedback-report';

  Carp::croak "too few subparts for ARF report" unless $mime->subparts >= 3;

  my ($description_part, $report_part, $original_part) = $mime->subparts;

  my $report_header = $report_part->content_type;
  my $report_ct = Email::MIME::ContentType::parse_content_type($report_header);
  Carp::croak "bad content type '$report_header' for machine-readable section"
    unless $report_ct->{type}  eq 'message'
    and    $report_ct->{subtype} eq 'feedback-report';

  my $self = bless {
    mime             => $mime,
    description_part => $description_part,
    original_part    => $original_part,
  } => $class;

  $self->{fields} = $self->_email_from_body($report_part, 1)->header_obj;
  $self->{original_email} = $self->_email_from_body($original_part);

  return $self;
}

sub _email_from_body {
  my ($self, $src_email, $append_nl) = @_;

  my $src_email_body = $src_email->body;

  $src_email_body =~ s/\A(\x0d|\x0a)+//g;

  my $email = Email::MIME->new(
    $append_nl ? "$src_email_body\n" : $src_email_body
  );
}


sub create {
  my ($class, %arg) = @_;

  require Email::MIME::Creator;

  my $description_part = Email::MIME->create(
    attributes => { content_type => 'text/plain' },
    body       => $arg{description},
  );

  my $original_body = ref $arg{original_email}
                    ? Scalar::Util::blessed $arg{original_email}
                      ? $arg{original_email}->as_string
                      : ${ $arg{original_email} }
                    : $arg{original_email};

  $description_part->header_set('Date');

  my $original_part = Email::MIME->create(
    attributes => { content_type => 'message/rfc822' },
    body       => $original_body,
  );

  $original_part->header_set('Date');

  my $field_pairs = ref $arg{fields} eq 'HASH'
                  ? [ %{ $arg{fields} } ]
                  : $arg{fields};

  my $fields = Email::Simple->create(header => $field_pairs);

  $fields->header_set('Date');

  unless (defined $fields->header('user-agent')) {
    $fields->header_set(
      'User-Agent',
      "$class/" . ($class->VERSION || '(dev)')
    );
  }

  unless (defined $fields->header('version')) {
    $fields->header_set('Version', "1");
  }

  unless (defined $fields->header('Feedback-Type')) {
    $fields->header_set('Feedback-Type', "other");
  }

  my $report_part = Email::MIME->create(
    attributes => { content_type => 'message/feedback-report' },
    body       => $fields->header_obj->as_string,
  );

  $report_part->header_set('Date');

  my $report = Email::MIME->create(
    attributes => {
      # It is so asinine that I need to do this!  Only certain blessed
      # attributes are heeded, here.  The rest are dropped. -- rjbs, 2007-03-21
      content_type  => 'multipart/report; report-type="feedback-report"',
    },
    parts  => [ $description_part, $report_part, $original_part ],

    header     => $arg{header}     || [],
    header_str => $arg{header_str} || [],
  );

  $class->new($report);
}


sub as_email {
  return Email::MIME->new($_[0]->as_string)
}


sub as_string { $_[0]->{mime}->as_string }


sub original_email {
  $_[0]->{original_email}
}


sub _description_part { $_[0]->{description_part} }

sub description {
  $_[0]->_description_part->body;
}

sub _fields { $_[0]->{fields} }


sub field {
  my ($self, $field) = @_;

  return $self->_fields->header($field);
}


sub feedback_type { $_[0]->field('Feedback-Type'); }
sub user_agent    { $_[0]->field('User-Agent');    }
sub arf_version   { $_[0]->field('Version');       }


1;

__END__