Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Browse files
Browse the repository at this point in the history
r31029@knight: rjbs | 2007-03-21 09:22:39 -0400
release
- Loading branch information
0 parents
commit 2ae851c
Showing
14 changed files
with
921 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,7 @@ | ||
Revision history for Email::ARF::Report | ||
|
||
0.001 2007-03-21 | ||
add a lousy first-pass at create method | ||
|
||
0.000 2007-03-20 | ||
initial, totally experimental release |
Large diffs are not rendered by default.
Oops, something went wrong.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,23 @@ | ||
Changes | ||
inc/Module/Install.pm | ||
inc/Module/Install/Base.pm | ||
inc/Module/Install/Can.pm | ||
inc/Module/Install/Fetch.pm | ||
inc/Module/Install/Makefile.pm | ||
inc/Module/Install/Metadata.pm | ||
inc/Module/Install/Win32.pm | ||
inc/Module/Install/WriteAll.pm | ||
lib/Email/ARF.pm | ||
lib/Email/ARF/Report.pm | ||
LICENSE | ||
Makefile.PL | ||
MANIFEST This list of files | ||
META.yml | ||
README | ||
t/basic.t | ||
t/create.t | ||
t/messages/example-0.msg | ||
t/messages/example-1.msg | ||
t/messages/example-2.msg | ||
t/pod-coverage.t | ||
t/pod.t |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,17 @@ | ||
use strict; | ||
use warnings; | ||
|
||
use inc::Module::Install; | ||
|
||
name ('Email-ARF'); | ||
author ('Ricardo SIGNES <rjbs@cpan.org>'); | ||
license ('perl'); | ||
version_from ('lib/Email/ARF/Report.pm'); | ||
|
||
requires('Email::MIME' => 1.859); # subparts method | ||
requires('Params::Util' => 0.00); # no minimum; used for _INSTANCE | ||
requires('Scalar::Util' => 0.00); # unknown minimum; used for blessed | ||
|
||
requires('Email::MIME::ContentType' => 0.00); # no minimum | ||
|
||
WriteAll(); |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,3 @@ | ||
|
||
Email::ARF::Report represents the contents of a email feedback report in Abuse | ||
Report Format. |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,20 @@ | ||
|
||
package Email::ARF; | ||
|
||
=head1 NAME | ||
Email::ARF - abuse report format (placeholder module) | ||
=head1 VERSION | ||
version 0.000 | ||
$Id$ | ||
=cut | ||
|
||
our $VERSION = '0.000'; | ||
|
||
warn "This module does nothing." unless $ENV{HARNESS_ACTIVE}; | ||
|
||
1; |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,262 @@ | ||
use strict; | ||
use warnings; | ||
|
||
package Email::ARF::Report; | ||
|
||
use Carp (); | ||
use Email::MIME 1.859 (); | ||
use Email::MIME::ContentType (); | ||
use Scalar::Util (); | ||
use Params::Util qw(_INSTANCE); | ||
|
||
=head1 NAME | ||
Email::ARF::Report - interpret Abuse Reporting Format (ARF) messages | ||
=head1 VERSION | ||
version 0.001 | ||
$Id$ | ||
B<Achtung!> Yes, version 0.001. This is a prototype. This module will | ||
definitely continue to exist, but maybe the interface will change radically | ||
once more people have seen it and tried to use it. Don't rely on its interface | ||
to keep you employed, just yet. | ||
=cut | ||
|
||
our $VERSION = '0.001'; | ||
|
||
=head1 SYNOPSIS | ||
my $report = Email::ARF::Report->new($text); | ||
=head1 DESCRIPTION | ||
=head1 METHODS | ||
=head2 new | ||
my $report = Email::ARF::Report->new($message); | ||
Given either an Email::MIME object or a string containing the text of an email | ||
message, this method returns a new Email::ARF::Report object. If the given | ||
message source is not a valid report in ARF format, an exception is raised. | ||
=cut | ||
|
||
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->{discrete} eq 'multipart' | ||
and $ct->{composite} 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->{discrete} eq 'message' | ||
and $report_ct->{composite} eq 'feedback-report'; | ||
|
||
my $self = bless { | ||
description_part => $description_part, | ||
report_part => $report_part, | ||
original_part => $original_part, | ||
} => $class; | ||
|
||
$self->{fields} = $self->_email_from_body($report_part)->header_obj; | ||
$self->{original_email} = $self->_email_from_body($original_part); | ||
|
||
return $self; | ||
} | ||
|
||
sub _email_from_body { | ||
my ($self, $src_email) = @_; | ||
|
||
my $src_email_body = $src_email->body; | ||
|
||
$src_email_body =~ s/\A(\x0d|\x0a)+//g; | ||
|
||
my $email = Email::Simple->new($src_email_body); | ||
} | ||
|
||
=head2 create | ||
my $mail = Email::ARF::Report->create( | ||
original_email => $email, | ||
description => $description, | ||
fields => \%fields, # or \@fields | ||
); | ||
This method creates a new ARF report from scratch, returning it as an | ||
Email::MIME message. | ||
=cut | ||
|
||
sub create { | ||
my ($class, %arg) = @_; | ||
|
||
require Email::MIME::Creator; | ||
|
||
my $description_part = Email::MIME->create( | ||
attributes => { content_type => 'text/plain' }, | ||
body => $arg{description}, | ||
); | ||
|
||
$description_part->header_set('Date'); | ||
|
||
my $original_part = Email::MIME->create( | ||
attributes => { content_type => 'message/rfc822' }, | ||
body => $arg{original_email}->as_string, | ||
); | ||
|
||
$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); | ||
} | ||
|
||
unless (defined $fields->header('version')) { | ||
$fields->header_set('Version', "0.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"', | ||
}, | ||
header => $arg{header} || [], | ||
parts => [ $description_part, $report_part, $original_part ], | ||
); | ||
|
||
return $report; | ||
} | ||
|
||
=head2 original_email | ||
This method returns an Email::Simple object containing the original message to | ||
which the report refers. Bear in mind that this message may have been edited | ||
by the reporter to remove identifying information. | ||
=cut | ||
|
||
sub original_email { | ||
$_[0]->{original_email} | ||
} | ||
|
||
=head2 description | ||
This method returns the human-readable description of the report, taken from | ||
the body of the human-readable (first) subpart of the report. | ||
=cut | ||
|
||
sub _description_part { $_[0]->{description_part} } | ||
|
||
sub description { | ||
$_[0]->_description_part->body; | ||
} | ||
|
||
sub _report_part { | ||
$_[0]->{report_part} | ||
} | ||
|
||
sub _fields { $_[0]->{fields} } | ||
|
||
=head2 field | ||
my $value = $report->field($field_name); | ||
my @values = $report->field($field_name); | ||
This method returns the value for the given field from the second, | ||
machine-readable part of the report. In scalar context, it returns the first | ||
value for the field. | ||
=cut | ||
|
||
sub field { | ||
my ($self, $field) = @_; | ||
|
||
return $self->_fields->header($field); | ||
} | ||
|
||
=head2 feedback_type | ||
=head2 user_agent | ||
=head2 arf_version | ||
These methods are shorthand for retrieving the fields of the same name, except | ||
for C<arf_version>, which returns the F<Version> header. It has been renamed | ||
to avoid confusion with the universal C<VERSION> method. | ||
=cut | ||
|
||
sub feedback_type { $_[0]->field('Feedback-Type'); } | ||
sub user_agent { $_[0]->field('User-Agent'); } | ||
sub arf_version { $_[0]->field('Version'); } | ||
|
||
=head1 SEE ALSO | ||
L<http://www.mipassoc.org/arf/> | ||
L<http://www.shaftek.org/publications/drafts/abuse-report/draft-shafranovich-feedback-report-01.txt> | ||
=head1 PERL EMAIL PROJECT | ||
This module is maintained by the Perl Email Project | ||
L<http://emailproject.perl.org/wiki/Email::ARF::Report> | ||
=head1 AUTHORS | ||
Ricardo SIGNES E<lt>F<rjbs@cpan.org>E<gt> | ||
=head1 COPYRIGHT AND LICENSE | ||
Copyright 2007 by Ricardo SIGNES | ||
This library is free software; you can redistribute it and/or modify it under | ||
the same terms as Perl itself. | ||
=cut | ||
|
||
1; |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,35 @@ | ||
#!perl -T | ||
use strict; | ||
use warnings; | ||
|
||
use Test::More tests => 8; | ||
|
||
BEGIN { use_ok('Email::ARF::Report'); } | ||
|
||
sub test_report { | ||
my ($filename) = @_; | ||
open my $fh, '<', "t/messages/$filename.msg" or die "couldn't read file: $!"; | ||
my $content = do { local $/; <$fh> }; | ||
my $report = Email::ARF::Report->new($content); | ||
} | ||
|
||
my $report = test_report('example-0'); | ||
isa_ok($report, 'Email::ARF::Report'); | ||
|
||
is($report->feedback_type, 'abuse', "correct feedback_type"); | ||
is($report->user_agent, 'SomeGenerator/1.0', "correct user_agent"); | ||
is($report->arf_version, '0.1', "correct arf_version"); | ||
|
||
is($report->field('version'), '0.1', "field accessor works"); | ||
|
||
is( | ||
$report->original_email->header('subject'), | ||
'Earn money', | ||
'we can get headers from the original message via the report', | ||
); | ||
|
||
like( | ||
$report->description, | ||
qr/\QIP 10.67.41.167\E/, | ||
"we seem to be able to get the report description", | ||
); |
Oops, something went wrong.