r9497 - in /trunk/libemail-abstract-perl: ./ debian/ lib/Email/ lib/Email/Abstract/ t/ t/lib/Test/
gregoa-guest at users.alioth.debian.org
gregoa-guest at users.alioth.debian.org
Sat Nov 17 15:48:18 UTC 2007
Author: gregoa-guest
Date: Sat Nov 17 15:48:17 2007
New Revision: 9497
URL: http://svn.debian.org/wsvn/?sc=1&rev=9497
Log:
New upstream release.
Added:
trunk/libemail-abstract-perl/lib/Email/Abstract/Plugin.pm
- copied unchanged from r9496, branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/Plugin.pm
trunk/libemail-abstract-perl/t/abstractions.t
- copied unchanged from r9496, branches/upstream/libemail-abstract-perl/current/t/abstractions.t
trunk/libemail-abstract-perl/t/example.msg
- copied unchanged from r9496, branches/upstream/libemail-abstract-perl/current/t/example.msg
trunk/libemail-abstract-perl/t/unknown.t
- copied unchanged from r9496, branches/upstream/libemail-abstract-perl/current/t/unknown.t
Removed:
trunk/libemail-abstract-perl/t/abs-object.t
trunk/libemail-abstract-perl/t/classy.t
Modified:
trunk/libemail-abstract-perl/Changes
trunk/libemail-abstract-perl/MANIFEST
trunk/libemail-abstract-perl/META.yml
trunk/libemail-abstract-perl/Makefile.PL
trunk/libemail-abstract-perl/debian/changelog
trunk/libemail-abstract-perl/lib/Email/Abstract.pm
trunk/libemail-abstract-perl/lib/Email/Abstract/EmailMIME.pm
trunk/libemail-abstract-perl/lib/Email/Abstract/EmailSimple.pm
trunk/libemail-abstract-perl/lib/Email/Abstract/MIMEEntity.pm
trunk/libemail-abstract-perl/lib/Email/Abstract/MailInternet.pm
trunk/libemail-abstract-perl/lib/Email/Abstract/MailMessage.pm
trunk/libemail-abstract-perl/t/lib/Test/EmailAbstract.pm
trunk/libemail-abstract-perl/t/subclass.t
Modified: trunk/libemail-abstract-perl/Changes
URL: http://svn.debian.org/wsvn/trunk/libemail-abstract-perl/Changes?rev=9497&op=diff
==============================================================================
--- trunk/libemail-abstract-perl/Changes (original)
+++ trunk/libemail-abstract-perl/Changes Sat Nov 17 15:48:17 2007
@@ -1,38 +1,69 @@
-Revision history for Perl extension Email::Abstract.
+Revision history for Email-Abstract.
-2.132 2007-03-22
- packaging improvements
+2.134 2007-11-16
+ (no code changes from previous dev release)
-2.131 2006-08-22
- pod tests
+2.133_05 2007-11-11
+ [BUG FIXES]
+ added is_available method to MIMEEntity plugin
-2.13 2006-07-24
- test for and permit passing Email::Abstract objects to Email::Abstract
- class methods
+2.133_04 2007-09-24
+ [ENHANCEMENTS]
+ created Email::Abstract::Plugin base class; please use it!
+ added is_available method to plugins
-2.12 2006-07-24
- don't use MIME::Entity in test if it's not available
+ [BUG FIXES]
+ is_available in the Mail::Internet adapter should solve header
+ folding issues (by preventing you from using it when it can't work)
-2.11 2006-07-22
- better test planning
+2.133_03 2007-08-??
+ diagnostics in output to indicate what version of a module we used
-2.10 2006-07-21
- add a new method to create wrapper objects
- handle subclasses /properly/ (correct ISA order)
- improved tests and test coverage
- miscellaneous refactoring
- update PEP URL
- update documentation
+2.133_02 2007-07-??
+ fix test planning
-2.01 2004-11-04
- Minor Documentation Fix
- Author Change
- PEP Contact Added
+2.133_01 2007-07-??
+ add test to ensure that "can't handle" exception is thrown ASAP
+ remove unexplained requirement for perl 5.6
+ fix Mail::Internet header fetching to unfold headers
+ fix Mail::Message body setter, which hosed newlines
+ fix body handling for Mail::Internet
+ improved consistency of method used to find adapter class
+ improved tests and test coverage
-2.0 2004-08-25 12:12:37 BST
- Handle subclasses
+2.132 2007-03-22
+ packaging improvements
-0.01 2004-05-26 16:47 20
- original version; created by h2xs 1.22 with options
- -AX -b 5.6.0 -n Email::Abstract
+2.131 2006-08-22
+ pod tests
+2.13 2006-07-24
+ test for and permit passing Email::Abstract objects to Email::Abstract
+ class methods
+
+2.12 2006-07-24
+ don't use MIME::Entity in test if it's not available
+
+2.11 2006-07-22
+ better test planning
+
+2.10 2006-07-21
+ add a new method to create wrapper objects
+ handle subclasses /properly/ (correct ISA order)
+ improved tests and test coverage
+ miscellaneous refactoring
+ update PEP URL
+ update documentation
+
+2.01 2004-11-04
+ Minor Documentation Fix
+ Author Change
+ PEP Contact Added
+
+2.0 2004-08-25 12:12:37 BST
+ Handle subclasses
+
+0.01 2004-05-26 16:47 20
+ original version; created by h2xs 1.22 with options
+ -AX -b 5.6.0 -n Email::Abstract
+
Modified: trunk/libemail-abstract-perl/MANIFEST
URL: http://svn.debian.org/wsvn/trunk/libemail-abstract-perl/MANIFEST?rev=9497&op=diff
==============================================================================
--- trunk/libemail-abstract-perl/MANIFEST (original)
+++ trunk/libemail-abstract-perl/MANIFEST Sat Nov 17 15:48:17 2007
@@ -5,14 +5,16 @@
lib/Email/Abstract/MailInternet.pm
lib/Email/Abstract/MailMessage.pm
lib/Email/Abstract/MIMEEntity.pm
+lib/Email/Abstract/Plugin.pm
Makefile.PL
MANIFEST This list of files
README
-t/abs-object.t
-t/classy.t
+t/abstractions.t
t/lib/Test/EmailAbstract.pm
t/pod.t
t/pod-coverage.t
t/subclass.t
+t/unknown.t
+t/example.msg
LICENSE
META.yml Module meta-data (added by MakeMaker)
Modified: trunk/libemail-abstract-perl/META.yml
URL: http://svn.debian.org/wsvn/trunk/libemail-abstract-perl/META.yml?rev=9497&op=diff
==============================================================================
--- trunk/libemail-abstract-perl/META.yml (original)
+++ trunk/libemail-abstract-perl/META.yml Sat Nov 17 15:48:17 2007
@@ -1,9 +1,9 @@
--- #YAML:1.0
name: Email-Abstract
-version: 2.132
+version: 2.134
abstract: ~
license: perl
-generated_by: ExtUtils::MakeMaker version 6.31
+generated_by: ExtUtils::MakeMaker version 6.36_01
distribution_type: module
requires:
Class::ISA: 0.20
Modified: trunk/libemail-abstract-perl/Makefile.PL
URL: http://svn.debian.org/wsvn/trunk/libemail-abstract-perl/Makefile.PL?rev=9497&op=diff
==============================================================================
--- trunk/libemail-abstract-perl/Makefile.PL (original)
+++ trunk/libemail-abstract-perl/Makefile.PL Sat Nov 17 15:48:17 2007
@@ -1,4 +1,3 @@
-use 5.006;
use strict;
use ExtUtils::MakeMaker;
Modified: trunk/libemail-abstract-perl/debian/changelog
URL: http://svn.debian.org/wsvn/trunk/libemail-abstract-perl/debian/changelog?rev=9497&op=diff
==============================================================================
--- trunk/libemail-abstract-perl/debian/changelog (original)
+++ trunk/libemail-abstract-perl/debian/changelog Sat Nov 17 15:48:17 2007
@@ -1,5 +1,6 @@
-libemail-abstract-perl (2.132-2) UNRELEASED; urgency=low
+libemail-abstract-perl (2.134-1) UNRELEASED; urgency=low
+ * New upstream release.
* debian/control: Added: Vcs-Svn field (source stanza); Vcs-Browser
field (source stanza); Homepage field (source stanza). Removed:
Homepage pseudo-field (Description); XS-Vcs-Svn fields.
Modified: trunk/libemail-abstract-perl/lib/Email/Abstract.pm
URL: http://svn.debian.org/wsvn/trunk/libemail-abstract-perl/lib/Email/Abstract.pm?rev=9497&op=diff
==============================================================================
--- trunk/libemail-abstract-perl/lib/Email/Abstract.pm (original)
+++ trunk/libemail-abstract-perl/lib/Email/Abstract.pm Sat Nov 17 15:48:17 2007
@@ -1,94 +1,105 @@
package Email::Abstract;
use Carp;
use Email::Simple;
-use 5.006;
+# use 5.006;
+# use warnings;
use strict;
-use warnings;
-our $VERSION = '2.132';
-use Module::Pluggable search_path => [ __PACKAGE__ ], require => 1;
+$Email::Abstract::VERSION = '2.134';
+use Module::Pluggable
+ search_path => [__PACKAGE__],
+ except => 'Email::Abstract::Plugin',
+ require => 1;
my @plugins = __PACKAGE__->plugins(); # Requires them.
-my %adapter_for = map { $_->target => $_ } @plugins;
+my %adapter_for =
+ map { $_->target => $_ }
+ grep {
+ my $avail = eval { $_->is_available };
+ $@ ? ($@ =~ /Can't locate object method "is_available"/) : $avail;
+ }
+ @plugins;
sub object {
- my ($self) = @_;
- return unless ref $self;
- return $$self;
+ my ($self) = @_;
+ return unless ref $self;
+ return $self->[0];
}
sub new {
- my ($class, $foreign) = @_;
-
- return $foreign if eval { $foreign->isa($class) };
-
- $class = ref($class) || $class;
-
- $foreign = Email::Simple->new($foreign) unless ref $foreign;
-
- if (
- $adapter_for{ref $foreign} or grep { $foreign->isa($_) } keys %adapter_for
- ) {
- return bless \$foreign => $class;
- }
-
- croak "Don't know how to handle " . ref $foreign;
+ my ($class, $foreign) = @_;
+
+ return $foreign if eval { $foreign->isa($class) };
+
+ $foreign = Email::Simple->new($foreign) unless ref $foreign;
+
+ my $adapter = $class->__class_for($foreign); # dies if none available
+ return bless [ $foreign, $adapter ] => $class;
}
sub __class_for {
- my ($self, $foreign, $method) = @_;
-
- my $f_class = ref($foreign) || $foreign;
-
- return $adapter_for{ $f_class } if exists $adapter_for{ $f_class };
-
+ my ($self, $foreign, $method, $skip_super) = @_;
+ $method ||= 'handle';
+
+ my $f_class = ref $foreign;
+ $f_class = $foreign unless $f_class;;
+
+ return $f_class if ref $foreign and $f_class->isa($self);
+
+ return $adapter_for{$f_class} if $adapter_for{$f_class};
+
+ if (not $skip_super) {
require Class::ISA;
for my $base (Class::ISA::super_path($f_class)) {
- return $adapter_for{ $base } if exists $adapter_for{ $base }
+ return $adapter_for{$base} if $adapter_for{$base};
}
-
- croak "Don't know how to handle " . $f_class;
-}
-
-sub _obj_and_args {
+ }
+
+ Carp::croak "Don't know how to $method $f_class";
+}
+
+sub _adapter_obj_and_args {
my $self = shift;
- return @_ unless my $thing = $self->object;
- return ($thing, @_);
+ if (my $thing = $self->object) {
+ return ($self->[1], $thing, @_);
+ } else {
+ my $thing = shift;
+ my $adapter = $self->__class_for(ref $thing ? $thing : 'Email::Simple');
+ return ($adapter, $thing, @_);
+ }
}
for my $func (qw(get_header get_body set_header set_body as_string)) {
- no strict 'refs';
- *$func = sub {
- my $self = shift;
- my ($thing, @args) = $self->_obj_and_args(@_);
-
- # In the event of Email::Abstract->get_body($email_abstract), convert
- # it into an object method call.
- $thing = $thing->object if eval { $thing->isa($self) };
-
- unless (ref $thing) {
- croak "can't alter string in place" if substr($func, 0, 3) eq 'set';
- $thing = Email::Simple->new($thing)
- }
-
- my $class = $self->__class_for($thing, $func);
- return $class->$func($thing, @args);
- };
+ no strict 'refs';
+ *$func = sub {
+ my $self = shift;
+ my ($adapter, $thing, @args) = $self->_adapter_obj_and_args(@_);
+
+ # In the event of Email::Abstract->get_body($email_abstract), convert
+ # it into an object method call.
+ $thing = $thing->object if eval { $thing->isa($self) };
+
+ # I suppose we could work around this by leaving @_ intact and assigning to
+ # it. That seems ... not good. -- rjbs, 2007-07-18
+ unless (ref $thing) {
+ Carp::croak "can't alter string in place" if substr($func, 0, 3) eq 'set';
+ $thing = Email::Simple->new($thing);
+ }
+
+ return $adapter->$func($thing, @args);
+ };
}
sub cast {
- my $self = shift;
- my ($from, $to) = $self->_obj_and_args(@_);
-
- croak "Don't know how to construct $to objects"
- unless $adapter_for{ $to } and $adapter_for{ $to }->can('construct');
-
- my $from_string = ref($from) ? $self->as_string($from) : $from;
-
- return $adapter_for{ $to }->construct($from_string);
-}
-
-# Preloaded methods go here.
+ my $self = shift;
+ my ($from_adapter, $from, $to) = $self->_adapter_obj_and_args(@_);
+
+ my $adapter = $self->__class_for($to, 'construct', 1);
+
+ my $from_string = ref($from) ? $from_adapter->as_string($from) : $from;
+
+ return $adapter->construct($from_string);
+}
1;
__END__
@@ -111,7 +122,6 @@
$email->set_header(Subject => "My new subject");
my $body = $email->get_body;
- $email->set_body("Hello\nTest message\n");
$rfc822 = $email->as_string;
@@ -120,26 +130,29 @@
=head1 DESCRIPTION
C<Email::Abstract> provides module writers with the ability to write
-representation-independent mail handling code. For instance, in the
-cases of C<Mail::Thread> or C<Mail::ListDetector>, a key part of the
-code involves reading the headers from a mail object. Where previously
-one would either have to specify the mail class required, or to build a
-new object from scratch, C<Email::Abstract> can be used to perform
-certain simple operations on an object regardless of its underlying
-representation.
-
-C<Email::Abstract> currently supports C<Mail::Internet>,
-C<MIME::Entity>, C<Mail::Message>, C<Email::Simple> and C<Email::MIME>.
-Other representations are encouraged to create their own
-C<Email::Abstract::*> class by copying C<Email::Abstract::EmailSimple>.
-All modules installed under the C<Email::Abstract> hierarchy will be
-automatically picked up and used.
+simple, representation-independent mail handling code. For instance, in the
+cases of C<Mail::Thread> or C<Mail::ListDetector>, a key part of the code
+involves reading the headers from a mail object. Where previously one would
+either have to specify the mail class required, or to build a new object from
+scratch, C<Email::Abstract> can be used to perform certain simple operations on
+an object regardless of its underlying representation.
+
+C<Email::Abstract> currently supports C<Mail::Internet>, C<MIME::Entity>,
+C<Mail::Message>, C<Email::Simple> and C<Email::MIME>. Other representations
+are encouraged to create their own C<Email::Abstract::*> class by copying
+C<Email::Abstract::EmailSimple>. All modules installed under the
+C<Email::Abstract> hierarchy will be automatically picked up and used.
=head1 METHODS
All of these methods may be called either as object methods or as class
methods. When called as class methods, the email object (of any class
-supported by Email::Abstract) must be prepended to the list of arguments.
+supported by Email::Abstract) must be prepended to the list of arguments, like
+so:
+
+ my $return = Email::Abstract->method($message, @args);
+
+This is provided primarily for backwards compatibility.
=head2 new
@@ -155,17 +168,15 @@
=head2 get_header
my $header = $email->get_header($header_name);
- my $header = Email::Abstract->get_header($message, $header_name);
my @headers = $email->get_header($header_name);
- my @headers = Email::Abstract->get_header($message, $header_name);
-
-This returns the value or list of values of the given header.
+
+This returns the values for the given header. In scalar context, it returns
+the first value.
=head2 set_header
- $email->set_header($header => @lines);
- Email::Abstract->set_header($message, $header => @lines);
+ $email->set_header($header => @values);
This sets the C<$header> header to the given one or more values.
@@ -173,30 +184,32 @@
my $body = $email->get_body;
- my $body = Email::Abstract->get_body($message);
-
This returns the body as a string.
=head2 set_body
$email->set_body($string);
- Email::Abstract->set_body($message, $string);
-
This changes the body of the email to the given string.
+B<WARNING!> You probably don't want to call this method, despite what you may
+think. Email message bodies are complicated, and rely on things like content
+type, encoding, and various MIME requirements. If you call C<set_body> on a
+message more complicated than a single-part seven-bit plain-text message, you
+are likely to break something. If you need to do this sort of thing, you
+should probably use a specific message class from end to end.
+
+This method is left in place for backwards compatibility.
+
=head2 as_string
my $string = $email->as_string;
- my $string = Email::Abstract->as_string($message);
-
-This returns the whole email as a string.
+This returns the whole email as a decoded string.
=head2 cast
my $mime_entity = $email->cast('MIME::Entity');
- my $mime_entity = Email::Abstract->cast($message, 'MIME::Entity');
This method will convert a message from one message class to another. It will
throw an exception if no adapter for the target class is known, or if the
Modified: trunk/libemail-abstract-perl/lib/Email/Abstract/EmailMIME.pm
URL: http://svn.debian.org/wsvn/trunk/libemail-abstract-perl/lib/Email/Abstract/EmailMIME.pm?rev=9497&op=diff
==============================================================================
--- trunk/libemail-abstract-perl/lib/Email/Abstract/EmailMIME.pm (original)
+++ trunk/libemail-abstract-perl/lib/Email/Abstract/EmailMIME.pm Sat Nov 17 15:48:17 2007
@@ -1,6 +1,10 @@
+use strict;
+
package Email::Abstract::EmailMIME;
-use strict;
-use base 'Email::Abstract::EmailSimple';
+
+use Email::Abstract::EmailSimple;
+BEGIN { @Email::Abstract::EmailMIME::ISA = 'Email::Abstract::EmailSimple' };
+
sub target { "Email::MIME" }
sub construct {
Modified: trunk/libemail-abstract-perl/lib/Email/Abstract/EmailSimple.pm
URL: http://svn.debian.org/wsvn/trunk/libemail-abstract-perl/lib/Email/Abstract/EmailSimple.pm?rev=9497&op=diff
==============================================================================
--- trunk/libemail-abstract-perl/lib/Email/Abstract/EmailSimple.pm (original)
+++ trunk/libemail-abstract-perl/lib/Email/Abstract/EmailSimple.pm Sat Nov 17 15:48:17 2007
@@ -1,5 +1,10 @@
+use strict;
+
package Email::Abstract::EmailSimple;
-use strict;
+
+use Email::Abstract::Plugin;
+BEGIN { @Email::Abstract::EmailSimple::ISA = 'Email::Abstract::Plugin' };
+
sub target { "Email::Simple" }
sub construct {
Modified: trunk/libemail-abstract-perl/lib/Email/Abstract/MIMEEntity.pm
URL: http://svn.debian.org/wsvn/trunk/libemail-abstract-perl/lib/Email/Abstract/MIMEEntity.pm?rev=9497&op=diff
==============================================================================
--- trunk/libemail-abstract-perl/lib/Email/Abstract/MIMEEntity.pm (original)
+++ trunk/libemail-abstract-perl/lib/Email/Abstract/MIMEEntity.pm Sat Nov 17 15:48:17 2007
@@ -1,6 +1,16 @@
+use strict;
package Email::Abstract::MIMEEntity;
-use strict;
-use base 'Email::Abstract::MailInternet';
+
+use Email::Abstract::Plugin;
+BEGIN { @Email::Abstract::MIMEEntity::ISA = 'Email::Abstract::MailInternet' };
+
+my $is_avail;
+sub is_available {
+ return $is_avail if defined $is_avail;
+ eval { require MIME::Entity; 1 };
+ return $is_avail = $@ ? 0 : 1;
+}
+
sub target { "MIME::Entity" }
sub construct {
Modified: trunk/libemail-abstract-perl/lib/Email/Abstract/MailInternet.pm
URL: http://svn.debian.org/wsvn/trunk/libemail-abstract-perl/lib/Email/Abstract/MailInternet.pm?rev=9497&op=diff
==============================================================================
--- trunk/libemail-abstract-perl/lib/Email/Abstract/MailInternet.pm (original)
+++ trunk/libemail-abstract-perl/lib/Email/Abstract/MailInternet.pm Sat Nov 17 15:48:17 2007
@@ -1,21 +1,42 @@
+use strict;
package Email::Abstract::MailInternet;
-use strict;
+
+use Email::Abstract::Plugin;
+BEGIN { @Email::Abstract::MailInternet::ISA = 'Email::Abstract::Plugin' };
+
sub target { "Mail::Internet" }
+
+# We need 1.77 because otherwise headers unfold badly.
+my $is_avail;
+sub is_available {
+ return $is_avail if defined $is_avail;
+ require Mail::Internet;
+ eval { Mail::Internet->VERSION(1.77) };
+ return $is_avail = $@ ? 0 : 1;
+}
sub construct {
require Mail::Internet;
my ($class, $rfc822) = @_;
- Mail::Internet->new([ split /\n/, $rfc822]);
+ Mail::Internet->new([ map { "$_\x0d\x0a" } split /\x0d\x0a/, $rfc822]);
}
sub get_header {
my ($class, $obj, $header) = @_;
- $obj->head->get($header);
+ my @values = $obj->head->get($header);
+
+ # No reason to s/// lots of values if we're just going to return one.
+ $#values = 0 if not wantarray;
+
+ chomp @values;
+ s/(?:\x0d\x0a|\x0a\x0d|\x0a|\x0d)\s+/ /g for @values;
+
+ return wantarray ? @values : $values[0];
}
-sub get_body {
+sub get_body {
my ($class, $obj) = @_;
- join "\n", @{$obj->body()};
+ join "", @{$obj->body()};
}
sub set_header {
@@ -24,9 +45,9 @@
$obj->head->replace($header, shift @data, ++$count) while @data;
}
-sub set_body {
+sub set_body {
my ($class, $obj, $body) = @_;
- $obj->body( split /\n/, $body );
+ $obj->body( map { "$_\n" } split /\n/, $body );
}
sub as_string { my ($class, $obj) = @_; $obj->as_string(); }
Modified: trunk/libemail-abstract-perl/lib/Email/Abstract/MailMessage.pm
URL: http://svn.debian.org/wsvn/trunk/libemail-abstract-perl/lib/Email/Abstract/MailMessage.pm?rev=9497&op=diff
==============================================================================
--- trunk/libemail-abstract-perl/lib/Email/Abstract/MailMessage.pm (original)
+++ trunk/libemail-abstract-perl/lib/Email/Abstract/MailMessage.pm Sat Nov 17 15:48:17 2007
@@ -1,5 +1,9 @@
+use strict;
package Email::Abstract::MailMessage;
-use strict;
+
+use Email::Abstract::Plugin;
+BEGIN { @Email::Abstract::MailMessage::ISA = 'Email::Abstract::Plugin' };
+
sub target {"Mail::Message" }
sub construct {
@@ -7,6 +11,7 @@
my ($class, $rfc822) = @_;
Mail::Message->read($rfc822);
}
+
sub get_header {
my ($class, $obj, $header) = @_;
$obj->head->get($header);
@@ -20,18 +25,17 @@
sub set_header {
my ($class, $obj, $header, @data) = @_;
$obj->head->delete($header);
- $obj->head->add($header, $_) for @data; # Madness
+ $obj->head->add($header, $_) for @data;
}
sub set_body {
my ($class, $obj, $body) = @_;
- $obj->body(Mail::Message::Body->new(data => [split /\n/, $body]));
- # Madness, madness
+ $obj->body(Mail::Message::Body->new(data => $body));
}
sub as_string {
my ($class, $obj) = @_;
- $obj->string();
+ $obj->string;
}
1;
Modified: trunk/libemail-abstract-perl/t/lib/Test/EmailAbstract.pm
URL: http://svn.debian.org/wsvn/trunk/libemail-abstract-perl/t/lib/Test/EmailAbstract.pm?rev=9497&op=diff
==============================================================================
--- trunk/libemail-abstract-perl/t/lib/Test/EmailAbstract.pm (original)
+++ trunk/libemail-abstract-perl/t/lib/Test/EmailAbstract.pm Sat Nov 17 15:48:17 2007
@@ -1,8 +1,15 @@
use strict;
-use warnings;
package Test::EmailAbstract;
use Test::More;
+
+sub new {
+ my ($class, $message) = @_;
+ my $simple = Email::Simple->new($message);
+ bless { simple => $simple } => $class;
+}
+
+sub simple { $_[0]->{simple} }
sub _call {
my ($wrapped, $object, $method, @args) = @_;
@@ -14,60 +21,97 @@
}
}
-# This is responsible for running 5 tests.
-sub _test_object {
- my ($wrapped, $class, $obj, $readonly) = @_;
-
- like(
- _call($wrapped, $obj, 'get_header', 'Subject'),
- qr/Re: Defect in XBD lround/,
- "Subject OK with $class"
- );
-
- like(
- _call($wrapped, $obj, 'get_body'),
- qr/Fred Tydeman/,
- "Body OK with $class"
- );
-
- eval {
- _call($wrapped, $obj, set_header =>
- "Subject",
- "New Subject"
- );
- };
-
- if ($readonly) {
- like($@, qr/can't alter string/, "can't alter an unwrapped string");
- } else {
- ok(!$@, "no exception on altering object via Email::Abstract");
- }
-
- eval {
- _call($wrapped, $obj, set_body =>
- "A completely new body"
- );
- };
-
- if ($readonly) {
- like($@, qr/can't alter string/, "can't alter an unwrapped string");
- } else {
- ok(!$@, "no exception on altering object via Email::Abstract");
- }
-
- if ($readonly) {
- pass("(no test; can't check altering unalterable alteration)");
- } else {
- like(
- _call($wrapped, $obj, 'as_string'),
- qr/Subject: New Subject.*completely new body$/ms,
- "set subject and body, restringified ok with $class"
- );
- }
+sub tests_per_class { 7 }
+sub tests_per_object { 8 }
+sub tests_per_module {
+ + 1
+ + 2 * $_[0]->tests_per_class
+ + 1 * $_[0]->tests_per_object
}
-sub class_ok { _test_object(0, @_); }
-sub wrapped_ok { _test_object(1, @_); }
+sub _do_tests {
+ my ($self, $is_wrapped, $class, $obj, $readonly) = @_;
+ if ($is_wrapped) {
+ isa_ok($obj, 'Email::Abstract', "wrapped $class object");
+ }
+
+ is(
+ _call($is_wrapped, $obj, 'get_header', 'Subject'),
+ 'Re: Defect in XBD lround',
+ "Subject OK with $class"
+ );
+
+ eval { _call($is_wrapped, $obj, set_header => "Subject", "New Subject"); };
+
+ if ($readonly) {
+ like($@, qr/can't alter string/, "can't alter an unwrapped string");
+ } else {
+ ok(!$@, "no exception on altering object via Email::Abstract");
+ }
+
+ my @receiveds = (
+ q{from mailman.opengroup.org ([192.153.166.9]) by deep-dark-truthful-mirror.pad with smtp (Exim 3.36 #1 (Debian)) id 18Buh5-0006Zr-00 for <posix at simon-cozens.org>; Wed, 13 Nov 2002 10:24:23 +0000},
+ q{(qmail 1679 invoked by uid 503); 13 Nov 2002 10:10:49 -0000},
+ );
+
+ my @got = _call($is_wrapped, $obj, get_header => 'Received');
+ s/\t/ /g for @got;
+
+ is_deeply(
+ \@got,
+ \@receiveds,
+ "$class: received headers match up list context get_header",
+ );
+
+ my $got_body = _call($is_wrapped, $obj, 'get_body');
+ my $simple_body = $self->simple->body;
+
+ # I very much do not like doing this. Why is it needed?
+ $got_body =~ s/\x0d?\x0a?\z//;
+ $simple_body =~ s/\x0d?\x0a?\z//;
+
+ is(
+ $got_body,
+ $simple_body,
+ "correct stringification of $class; same as reference object",
+ );
+
+ is(
+ length $got_body,
+ length $simple_body,
+ "correct body length for $class",
+ );
+
+ eval { _call($is_wrapped, $obj, set_body => "A completely new body"); };
+
+ if ($readonly) {
+ like($@, qr/can't alter string/, "can't alter an unwrapped string");
+ } else {
+ ok(!$@, "no exception on altering object via Email::Abstract");
+ }
+
+ if ($readonly) {
+ pass("(no test; can't check altering unalterable alteration)");
+ } else {
+ like(
+ _call($is_wrapped, $obj, 'as_string'),
+ qr/Subject: New Subject.*completely new body$/ms,
+ "set subject and body, restringified ok with $class"
+ );
+ }
+}
+
+sub class_ok { shift->_do_tests(0, @_); }
+sub object_ok { shift->_do_tests(1, @_); }
+
+sub load {
+ my ($self, $class) = @_;
+ if (eval "require $class; Email::Abstract->__class_for('$class')") {
+ diag "testing $class with " . $class->VERSION;
+ } else {
+ skip "$class: unavailable", $self->tests_per_module;
+ }
+}
1;
Modified: trunk/libemail-abstract-perl/t/subclass.t
URL: http://svn.debian.org/wsvn/trunk/libemail-abstract-perl/t/subclass.t?rev=9497&op=diff
==============================================================================
--- trunk/libemail-abstract-perl/t/subclass.t (original)
+++ trunk/libemail-abstract-perl/t/subclass.t Sat Nov 17 15:48:17 2007
@@ -1,6 +1,7 @@
{
package MyMail;
- use base "Email::Simple";
+ use Email::Simple;
+ BEGIN { @MyMail::ISA = 'Email::Simple'; }
}
package main;
@@ -16,7 +17,10 @@
SKIP: {
skip "this test requires MIME::Entity", 1
- unless eval { require MIME::Entity; 1 };
+ unless eval {
+ require Email::Abstract::MIMEEntity;
+ Email::Abstract::MIMEEntity->is_available;
+ };
{ # should always adapt as if it's MIME::Entity, the nearest class
package MultiHopMail;
require MIME::Entity;
More information about the Pkg-perl-cvs-commits
mailing list