r9495 - in /branches/upstream/libemail-abstract-perl/current: ./ 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:46:42 UTC 2007
Author: gregoa-guest
Date: Sat Nov 17 15:46:42 2007
New Revision: 9495
URL: http://svn.debian.org/wsvn/?sc=1&rev=9495
Log:
[svn-upgrade] Integrating new upstream version, libemail-abstract-perl (2.134)
Added:
branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/Plugin.pm
branches/upstream/libemail-abstract-perl/current/t/abstractions.t
branches/upstream/libemail-abstract-perl/current/t/example.msg
branches/upstream/libemail-abstract-perl/current/t/unknown.t
Removed:
branches/upstream/libemail-abstract-perl/current/t/abs-object.t
branches/upstream/libemail-abstract-perl/current/t/classy.t
Modified:
branches/upstream/libemail-abstract-perl/current/Changes
branches/upstream/libemail-abstract-perl/current/MANIFEST
branches/upstream/libemail-abstract-perl/current/META.yml
branches/upstream/libemail-abstract-perl/current/Makefile.PL
branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract.pm
branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/EmailMIME.pm
branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/EmailSimple.pm
branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/MIMEEntity.pm
branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/MailInternet.pm
branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/MailMessage.pm
branches/upstream/libemail-abstract-perl/current/t/lib/Test/EmailAbstract.pm
branches/upstream/libemail-abstract-perl/current/t/subclass.t
Modified: branches/upstream/libemail-abstract-perl/current/Changes
URL: http://svn.debian.org/wsvn/branches/upstream/libemail-abstract-perl/current/Changes?rev=9495&op=diff
==============================================================================
--- branches/upstream/libemail-abstract-perl/current/Changes (original)
+++ branches/upstream/libemail-abstract-perl/current/Changes Sat Nov 17 15:46:42 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: branches/upstream/libemail-abstract-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libemail-abstract-perl/current/MANIFEST?rev=9495&op=diff
==============================================================================
--- branches/upstream/libemail-abstract-perl/current/MANIFEST (original)
+++ branches/upstream/libemail-abstract-perl/current/MANIFEST Sat Nov 17 15:46:42 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: branches/upstream/libemail-abstract-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libemail-abstract-perl/current/META.yml?rev=9495&op=diff
==============================================================================
--- branches/upstream/libemail-abstract-perl/current/META.yml (original)
+++ branches/upstream/libemail-abstract-perl/current/META.yml Sat Nov 17 15:46:42 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: branches/upstream/libemail-abstract-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libemail-abstract-perl/current/Makefile.PL?rev=9495&op=diff
==============================================================================
--- branches/upstream/libemail-abstract-perl/current/Makefile.PL (original)
+++ branches/upstream/libemail-abstract-perl/current/Makefile.PL Sat Nov 17 15:46:42 2007
@@ -1,4 +1,3 @@
-use 5.006;
use strict;
use ExtUtils::MakeMaker;
Modified: branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract.pm?rev=9495&op=diff
==============================================================================
--- branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract.pm (original)
+++ branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract.pm Sat Nov 17 15:46:42 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: branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/EmailMIME.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/EmailMIME.pm?rev=9495&op=diff
==============================================================================
--- branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/EmailMIME.pm (original)
+++ branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/EmailMIME.pm Sat Nov 17 15:46:42 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: branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/EmailSimple.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/EmailSimple.pm?rev=9495&op=diff
==============================================================================
--- branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/EmailSimple.pm (original)
+++ branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/EmailSimple.pm Sat Nov 17 15:46:42 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: branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/MIMEEntity.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/MIMEEntity.pm?rev=9495&op=diff
==============================================================================
--- branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/MIMEEntity.pm (original)
+++ branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/MIMEEntity.pm Sat Nov 17 15:46:42 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: branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/MailInternet.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/MailInternet.pm?rev=9495&op=diff
==============================================================================
--- branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/MailInternet.pm (original)
+++ branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/MailInternet.pm Sat Nov 17 15:46:42 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: branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/MailMessage.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/MailMessage.pm?rev=9495&op=diff
==============================================================================
--- branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/MailMessage.pm (original)
+++ branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/MailMessage.pm Sat Nov 17 15:46:42 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;
Added: branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/Plugin.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/Plugin.pm?rev=9495&op=file
==============================================================================
--- branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/Plugin.pm (added)
+++ branches/upstream/libemail-abstract-perl/current/lib/Email/Abstract/Plugin.pm Sat Nov 17 15:46:42 2007
@@ -1,0 +1,23 @@
+use strict;
+
+package Email::Abstract::Plugin;
+
+$Email::Abstract::Plugin::VERSION = '2.134';
+
+=head1 NAME
+
+Email::Abstract::Plugin - a base class for Email::Abstract plugins
+
+=head1 METHODS
+
+=head2 is_available
+
+This method returns true if the plugin should be considered available for
+registration. Plugins that return false from this method will not be
+registered when Email::Abstract is loaded.
+
+=cut
+
+sub is_available { 1 }
+
+1;
Added: branches/upstream/libemail-abstract-perl/current/t/abstractions.t
URL: http://svn.debian.org/wsvn/branches/upstream/libemail-abstract-perl/current/t/abstractions.t?rev=9495&op=file
==============================================================================
--- branches/upstream/libemail-abstract-perl/current/t/abstractions.t (added)
+++ branches/upstream/libemail-abstract-perl/current/t/abstractions.t Sat Nov 17 15:46:42 2007
@@ -1,0 +1,79 @@
+#!perl -T
+use strict;
+
+use Test::More;
+
+use lib 't/lib';
+use Test::EmailAbstract;
+
+my @classes
+ = qw(Email::MIME Email::Simple MIME::Entity Mail::Internet Mail::Message);
+
+plan tests => 2
+ + (@classes * 2 + 1) * Test::EmailAbstract->tests_per_object
+ + (@classes + 2) * Test::EmailAbstract->tests_per_class
+ + 1;
+
+use_ok("Email::Abstract");
+
+open FILE, '<t/example.msg';
+my $message = do { local $/; <FILE>; };
+close FILE;
+
+# Let's be generous and start with real CRLF, no matter what stupid thing the
+# VCS or archive tools have done to the message.
+$message =~ s/\x0a\x0d|\x0d\x0a|\x0d|\x0a/\x0d\x0a/g;
+
+my $tester = Test::EmailAbstract->new($message);
+
+is(
+ substr($message, -2, 2),
+ "\x0d\x0a",
+ "the message ends in a CRLF",
+);
+
+for my $class (@classes) {
+ SKIP: {
+ $tester->load($class);
+
+ {
+ my $obj = Email::Abstract->cast($message, $class);
+ my $email_abs = Email::Abstract->new($obj);
+ $tester->object_ok($class, $email_abs, 0);
+ }
+
+ {
+ my $simple = Email::Simple->new($message);
+ my $obj = Email::Abstract->cast($simple, $class);
+ my $email_abs = Email::Abstract->new($obj);
+ $tester->object_ok($class, $email_abs, 0);
+ }
+
+ {
+ my $obj = Email::Abstract->cast($message, $class);
+ $tester->class_ok($class, $obj, 0);
+ }
+ }
+}
+
+{
+ my $email_abs = Email::Abstract->new($message);
+ $tester->object_ok('plaintext', $email_abs, 0);
+ $tester->class_ok('plaintext (class)', $message, 1);
+}
+
+{
+ my $email_abs = Email::Abstract->new($message);
+ $tester->class_ok('Email::Abstract', $email_abs, 0);
+}
+
+{
+ # Ensure that we can use Email::Abstract->header($abstract, 'foo')
+ my $email_abs = Email::Abstract->new($message);
+
+ my $email_abs_new = Email::Abstract->new($email_abs);
+ ok(
+ $email_abs == $email_abs_new,
+ "trying to wrap a wrapper returns the wrapper; it doesn't re-wrap",
+ );
+}
Added: branches/upstream/libemail-abstract-perl/current/t/example.msg
URL: http://svn.debian.org/wsvn/branches/upstream/libemail-abstract-perl/current/t/example.msg?rev=9495&op=file
==============================================================================
--- branches/upstream/libemail-abstract-perl/current/t/example.msg (added)
+++ branches/upstream/libemail-abstract-perl/current/t/example.msg Sat Nov 17 15:46:42 2007
@@ -1,0 +1,42 @@
+Received: 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
+Received: (qmail 1679 invoked by uid 503); 13 Nov 2002 10:10:49 -0000
+Resent-Date: 13 Nov 2002 10:10:49 -0000
+Date: Wed, 13 Nov 2002 10:06:51 GMT
+From: Andrew Josey <ajosey at rdg.opengroup.org>
+Message-Id: <1021113100650.ZM12997 at skye.rdg.opengroup.org>
+In-Reply-To: Joanna Farley's message as of Nov 13, 9:56am.
+References: <200211120937.JAA28130 at xoneweb.opengroup.org>
+ <1021112125524.ZM7503 at skye.rdg.opengroup.org>
+ <3DD221BB.13116D47 at sun.com>
+X-Mailer: Z-Mail (5.0.0 30July97)
+To: austin-group-l at opengroup.org
+Subject: Re: Defect in XBD lround
+MIME-Version: 1.0
+Resent-Message-ID: <gZGK1B.A.uY.iUi09 at mailman>
+Resent-To: austin-group-l at opengroup.org
+Resent-From: austin-group-l at opengroup.org
+X-Mailing-List: austin-group-l:archive/latest/4823
+X-Loop: austin-group-l at opengroup.org
+Precedence: list
+X-Spam-Status: No, hits=-1.6 required=5.0
+Resent-Sender: austin-group-l-request at opengroup.org
+Content-Type: text/plain; charset=us-ascii
+
+Joanna, All
+
+Thanks. I got the following response from Fred Tydeman.
+
+On Nov 13, 9:56am in "Re: Defect in XBD lr", Joanna Farley wrote:
+> Sun's expert in this area after some discussions with a colleague
+> outside of Sun concluded that for lround, to align with both C99 and SUS
+> changes of the following form were necessary:
+> this line of text is really long and no one need worry about it but why was such a long text chosen to begin with i mean really??
+
+-----
+Andrew Josey The Open Group
+Austin Group Chair Apex Plaza,Forbury Road,
+Email: a.josey at opengroup.org Reading,Berks.RG1 1AX,England
+Tel: +44 118 9508311 ext 2250 Fax: +44 118 9500110
Modified: branches/upstream/libemail-abstract-perl/current/t/lib/Test/EmailAbstract.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libemail-abstract-perl/current/t/lib/Test/EmailAbstract.pm?rev=9495&op=diff
==============================================================================
--- branches/upstream/libemail-abstract-perl/current/t/lib/Test/EmailAbstract.pm (original)
+++ branches/upstream/libemail-abstract-perl/current/t/lib/Test/EmailAbstract.pm Sat Nov 17 15:46:42 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: branches/upstream/libemail-abstract-perl/current/t/subclass.t
URL: http://svn.debian.org/wsvn/branches/upstream/libemail-abstract-perl/current/t/subclass.t?rev=9495&op=diff
==============================================================================
--- branches/upstream/libemail-abstract-perl/current/t/subclass.t (original)
+++ branches/upstream/libemail-abstract-perl/current/t/subclass.t Sat Nov 17 15:46:42 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;
Added: branches/upstream/libemail-abstract-perl/current/t/unknown.t
URL: http://svn.debian.org/wsvn/branches/upstream/libemail-abstract-perl/current/t/unknown.t?rev=9495&op=file
==============================================================================
--- branches/upstream/libemail-abstract-perl/current/t/unknown.t (added)
+++ branches/upstream/libemail-abstract-perl/current/t/unknown.t Sat Nov 17 15:46:42 2007
@@ -1,0 +1,33 @@
+#!perl -T
+use strict;
+
+use Test::More;
+
+plan tests => 4;
+
+use_ok("Email::Abstract");
+
+BEGIN {
+ package Totally::Unknown::ToAll;
+ @Totally::Unknown::ToAll::ISA = ('Totally::Unknown');
+}
+
+for my $class ('Totally::Unknown', 'Totally::Unknown::ToAll') {
+ my $object = bless [] => $class;
+ my $abs = eval { Email::Abstract->new($object); };
+ like($@, qr/handle/, "exception on unknown object type");
+}
+
+open FILE, '<t/example.msg';
+my $message = do { local $/; <FILE>; };
+close FILE;
+
+# Let's be generous and start with real CRLF, no matter what stupid thing the
+# VCS or archive tools have done to the message.
+$message =~ s/\x0a\x0d|\x0d\x0a|\x0d|\x0a/\x0d\x0a/g;
+
+require Email::Simple;
+my $simple = Email::Simple->new($message);
+
+eval { Email::Abstract->cast($simple, 'Totally::Unknown::ToAll') };
+like($@, qr/don't know/i, "can't cast an object to an unknown class");
More information about the Pkg-perl-cvs-commits
mailing list