Hello HTML World with an image and another one
Email-MIME-CreateHTML-1.030/t/data/end.png 0000644 0165221 0000772 00000001503 11335311613 021054 0 ustar jamiel engineers 0000000 0000000 PNG
IHDR d d ̈g PLTE |{^CG\eRժ2` IDATxڕn @d?FՕ jZ_[ т0 6HNl>Yft_FL1F 4+n/` ;PUJ,JR\<$UX^nq ci$a $.a^-.$co /a X(,2ڸ$%`HXB%ZtHR HŢL$-&$%/9BЖ"HBcik~W$-۞~%9IyI$T&oNMt%C<]NERə!t{^47fx&p Fy6e%{-mT @:d+v20 $4ZxɋCDRTȾ%@a^vItG/ e%B$1"y YDۋbDĈ%12b^sH/ IDD$K2)BrX Nȥ ڢw.B ;!{9 K bX1Q[CX84 ɒ?cA[-ҳ VKUo)x\LM`r]Hczg?k R0W6wKU[.C>mWT8 IENDB` Email-MIME-CreateHTML-1.030/t/data/test_style.css 0000644 0165221 0000772 00000000064 11335311613 022512 0 ustar jamiel engineers 0000000 0000000 body {
font-family: Verdana, Arial, sans-serif;
}
Email-MIME-CreateHTML-1.030/t/Email-MIME-CreateHTML-Resolver.t 0000644 0165221 0000772 00000006203 11335311613 024317 0 ustar jamiel engineers 0000000 0000000 #!/usr/local/bin/perl
#
# Unit test for Email::MIME::CreateHTML::Resolver
#
# -t Trace
# -T Deep trace
#
use strict;
use Test::Assertions::TestScript;
#Compilation
require Email::MIME::CreateHTML::Resolver;
ASSERT($INC{'Email/MIME/CreateHTML/Resolver.pm'}, "Compiled Email::MIME::CreateHTML::Resolver version $Email::MIME::CreateHTML::Resolver::VERSION");
#Try some different URLs
my $obj = Email::MIME::CreateHTML::Resolver->new()->_select_resolver('http://www.bbc.co.uk/');
ASSERT(ref $obj eq 'Email::MIME::CreateHTML::Resolver::LWP', 'HTTP URL');
$obj = Email::MIME::CreateHTML::Resolver->new()->_select_resolver('https://ssl.bbc.co.uk/');
ASSERT(ref $obj eq 'Email::MIME::CreateHTML::Resolver::LWP', 'HTTPS URL');
$obj = Email::MIME::CreateHTML::Resolver->new()->_select_resolver('ftp://www.bbc.co.uk/');
ASSERT(ref $obj eq 'Email::MIME::CreateHTML::Resolver::LWP', 'FTP URL');
$obj = Email::MIME::CreateHTML::Resolver->new()->_select_resolver('/absolute/filepath/file.extension');
ASSERT(ref $obj eq 'Email::MIME::CreateHTML::Resolver::Filesystem', 'absolute filepath');
$obj = Email::MIME::CreateHTML::Resolver->new()->_select_resolver('some/filepath/file.extension');
ASSERT(ref $obj eq 'Email::MIME::CreateHTML::Resolver::Filesystem', 'relative filepath');
$obj = Email::MIME::CreateHTML::Resolver->new()->_select_resolver('\\server\filepath\file.extension');
ASSERT(ref $obj eq 'Email::MIME::CreateHTML::Resolver::Filesystem', 'UNC filepath');
$obj = Email::MIME::CreateHTML::Resolver->new()->_select_resolver('c:\some\filepath\file.extension');
ASSERT(ref $obj eq 'Email::MIME::CreateHTML::Resolver::Filesystem', 'windows-style filepath');
$obj = Email::MIME::CreateHTML::Resolver->new()->_select_resolver('file://some/filepath/file.extension');
ASSERT(ref $obj eq 'Email::MIME::CreateHTML::Resolver::Filesystem', 'file URL');
#Try custom resolver
my $resolver = new UnitTestResolver;
$obj = Email::MIME::CreateHTML::Resolver->new({resolver => $resolver})->_select_resolver('http://www.bbc.co.uk/');
ASSERT(ref $obj eq 'UnitTestResolver', 'Custom resolver');
#Error checking
ASSERT(DIED(sub { Email::MIME::CreateHTML::Resolver->new()->get_resource('')}) && $@ =~ /get_resource without a URI/, "No URI");
ASSERT(DIED(sub { Email::MIME::CreateHTML::Resolver->new({resolver => 1})->_select_resolver('abc')}), "Resolver not an object");
ASSERT(DIED(sub { Email::MIME::CreateHTML::Resolver->new({resolver => new Dummy()})->_select_resolver('abc')}) && $@ =~ /resolver does not seem to use the expected interface/, "Resolver doesn't have get_resource method");
ASSERT(DIED(sub { Email::MIME::CreateHTML::Resolver->new({object_cache => new Dummy()})->_select_resolver('abc')}) && $@ =~ /object_cache does not seem to use the expected cache interface/, "Dodgy object cache");
# Dummy object for error checking
package Dummy;
sub new {
return bless({}, shift);
}
#######################################################
#
# Trivial resource resolver for testing
#
#######################################################
package UnitTestResolver;
sub new {
return bless({}, shift());
}
sub get_resource {
return ("invariant value","invariant-name","text/plain","iso8859-1");
}
1;
Email-MIME-CreateHTML-1.030/t/pod.t 0000644 0165221 0000772 00000000201 11335311615 017632 0 ustar jamiel engineers 0000000 0000000 use Test::More;
eval "use Test::Pod 1.00";
plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
all_pod_files_ok();
Email-MIME-CreateHTML-1.030/t/Email-MIME-CreateHTML.t 0000644 0165221 0000772 00000023122 11335311613 022517 0 ustar jamiel engineers 0000000 0000000 #!/usr/local/bin/perl
##################################################################################
# -t : Trace
# -T : Deep Trace
# -m : send the emails that we create for each test (set $SMTP_HOST)
##################################################################################
use strict;
use vars qw/$opt_m/;
use Test::Assertions::TestScript(tests => 49, options => {'m=s' => \$opt_m});
use File::Slurp;
use File::Copy;
my $mailto = $opt_m || 'somebody@example.com';
# SetUp
my $text_body = "Hello World";
my $html_body = "Hello HTML World";
my ($html_in, $html_out);
#######################################################
#
# The tests
#
#######################################################
use Email::MIME;
use Email::MIME::CreateHTML;
ASSERT(1,"compiled version $Email::MIME::CreateHTML::VERSION");
#
# Test Mail Construction
#
# HTML, no embedded objects, no text alternative
# ----------------------------------------------
my $mime = Email::MIME->create_html(
header => [
From => 'unittest_a@example.co.uk',
To => $mailto,
Subject => 'HTML, no embedded objects, no text alternative',
],
body => $html_body,
);
ASSERT(ref $mime eq 'Email::MIME', "------ HTML, no embedded objects, no text alternative - Email::MIME object returned");
test_mime( $mime, qr'text/html', $html_body );
send_mail( $mime ) if($opt_m);
# HTML, no embedded objects, with text alternative
# ------------------------------------------------
$mime = Email::MIME->create_html(
header => [
From => 'unittest_b@example.co.uk',
To => $mailto,
Subject => 'HTML, no embedded objects, with text alternative',
],
body => $html_body,
text_body => $text_body,
);
ASSERT(ref $mime eq 'Email::MIME', "------ HTML, no embedded objects, with text alternative - Email::MIME object returned");
test_mime( $mime, qr'multipart/alternative', undef );
my @parts = $mime->parts;
ASSERT( scalar(@parts) == 2, "number of parts");
test_mime( $parts[0], qr'text/plain', $text_body );
test_mime( $parts[1], qr'text/html', $html_body );
send_mail( $mime ) if($opt_m);
# HTML with embedded objects, no text alternative
# using objects hash
# -----------------------------------------------
# inline_css is false, no base or base_rewrite
# -----------------------------------------------
$html_in = read_file( './data/CreateHTML_01.html' );
$html_out = $html_in;
$mime = Email::MIME->create_html(
header => [
From => 'unittest_c@example.co.uk',
To => $mailto,
Subject => 'HTML with embedded objects, no text alternative',
],
body => $html_in,
objects => {
'123@bbc.co.uk' => './data/end.png',
'landscapeview' => './data/landscape.jpg',
},
inline_css => 0,
);
ASSERT(ref $mime eq 'Email::MIME', "------ HTML with embedded objects, no text alternative - Email::MIME object returned");
test_mime( $mime, qr'multipart/related', undef );
@parts = $mime->parts;
ASSERT( scalar(@parts) == 3, "number of parts");
test_mime( $parts[0], qr'text/html', $html_out );
my $p = join '', map defined $_ ? $_->content_type : '', @parts[1..2];
ASSERT($p =~ m|image/png|i && $p =~ m|image/jpeg|i, "Mime types image/png and image/jpeg");
send_mail( $mime ) if($opt_m);
# HTML with embedded objects, with text alternative
# using embedded images
# -----------------------------------------------
# inline_css default on, base with base_rewrite, embed default on,
# multiple reference to same object do not cause multiple attached mime parts,
# can use objects and embed together, fully qualified links are not rewritten
# -----------------------------------------------
$html_in = read_file( './data/CreateHTML_02a.html' );
$html_out = read_file( './data/CreateHTML_02b.html' );
$mime = Email::MIME->create_html(
header => [
From => 'unittest_d@example.co.uk',
To => $mailto,
Subject => 'HTML with embedded objects, with text alternative',
],
body => $html_in,
text_body => $text_body,
base => './data',
objects => {
'123@bbc.co.uk' => 'end.png',
},
inline_javascript => 1,
);
ASSERT(ref $mime eq 'Email::MIME', "------ HTML with embedded objects, with text alternative - Email::MIME object returned");
test_mime( $mime, qr'multipart/alternative', undef );
@parts = $mime->parts;
ASSERT( scalar(@parts) == 2, "number of parts");
test_mime( $parts[0], qr'text/plain', $text_body );
test_mime( $parts[1], qr'multipart/related', undef );
my @sub_parts = defined $parts[1] ? $parts[1]->parts : ();
ASSERT( scalar(@sub_parts) == 3, "number of parts");
test_mime( $sub_parts[0], qr'text/html', $html_out );
my $sp = [map { defined($_) ? $_->content_type : () } @sub_parts[1..2]];
DUMP("Sub parts",$sp);
ASSERT((grep { m!image/png!i } @$sp), "MIME type image/png present");
ASSERT((grep { m!image/jpeg!i } @$sp), "MIME type image/jpeg present");
send_mail( $mime ) if($opt_m);
# HTML with embedded objects, no text alternative
# use a different char set
# -----------------------------------------------
# no base but have base_rewrite, embed is false
# -----------------------------------------------
$html_in = read_file( './data/CreateHTML_03a.html' );
$html_out = read_file( './data/CreateHTML_03b.html' );
$mime = Email::MIME->create_html(
header => [
From => 'unittest_e@example.co.uk',
To => $mailto,
Subject => 'HTML with embedded objects, no text alternative, uses ISO-8859-1',
],
body => $html_in,
body_attributes => { charset => 'ISO-8859-1' },
objects => {
'landscapeview' => './data/landscape.jpg',
},
embed => 0,
);
ASSERT(ref $mime eq 'Email::MIME', "------ HTML with embedded objects, no text alternative - Email::MIME object returned");
test_mime( $mime, qr'multipart/related', undef );
@parts = $mime->parts;
ASSERT( scalar(@parts) == 2, "number of parts");
test_mime( $parts[0], qr'text/html', $html_out );
test_mime( $parts[1], qr'image/jpeg', undef );
send_mail( $mime ) if($opt_m);
# Caching
# ----------------------------------------------
my $cache = "this is not a cache object";
ASSERT( copy( './data/landscape.jpg','./data/cache_test_landscape.jpg' ) &&
copy( './data/end.png','./data/cache_test_end.png' ), "------ Caching : Image files in place" );
$html_in = read_file( './data/CreateHTML_04a.html' );
$html_out = read_file( './data/CreateHTML_04b.html' );
# bad cache object
eval {
$mime = Email::MIME->create_html(
header => [
From => 'unittest_f@example.co.uk',
To => $mailto,
Subject => 'Test of caching',
],
body => $html_in,
base => './data',
objects => {
'abcdefghi@bbc.co.uk' => 'cache_test_end.png',
},
object_cache => $cache,
);
};
ASSERT( scalar( $@ =~ /object_cache must be an object/ ), "Bad object_cache caught");
# good cache object
$cache = new UnitTestCache();
$mime = Email::MIME->create_html(
header => [
From => 'unittest_f@example.co.uk',
To => $mailto,
Subject => 'Test of caching',
],
body => $html_in,
base => './data',
objects => {
'abcdefghi@bbc.co.uk' => 'cache_test_end.png',
},
object_cache => $cache,
);
ASSERT( ref $mime eq 'Email::MIME', "mime object created");
@parts = $mime->parts;
ASSERT( scalar(@parts) == 3, "number of parts");
test_mime( $parts[0], qr'text/html', $html_out );
test_mime( $parts[1], qr'image/png', undef );
test_mime( $parts[2], qr'image/jpeg', undef );
ASSERT( unlink('./data/cache_test_landscape.jpg', './data/cache_test_end.png') == 2, "Image files removed" );
$mime = Email::MIME->create_html(
header => [
From => 'unittest_f@example.co.uk',
To => $mailto,
Subject => 'Test of caching',
],
body => $html_in,
base => './data',
objects => {
'abcdefghi@bbc.co.uk' => 'cache_test_end.png',
},
object_cache => $cache,
);
ASSERT( ref $mime eq 'Email::MIME', "mime object created (second mail)");
@parts = $mime->parts;
ASSERT( scalar(@parts) == 3, "number of parts");
test_mime( $parts[0], qr'text/html', $html_out );
test_mime( $parts[1], qr'image/png', undef );
test_mime( $parts[2], qr'image/jpeg', undef );
send_mail( $mime ) if($opt_m);
# End of tests
#######################################################
#
# Subroutines
#
#######################################################
sub test_mime {
my ($mime, $exp_content_type, $exp_body) = @_;
my $got_content_type = defined $mime ? $mime->content_type : undef;
ASSERT( defined $got_content_type && $got_content_type =~ /^$exp_content_type/i, "content-type: $got_content_type");
if ( defined $exp_body ) {
my $got_body;
$exp_body =~ s/\s+$//g;
if(defined $mime) {
$got_body = $mime->body;
# we don't care about trailing white space
$got_body =~ s/\s+$//g;
# This is a quick fix to allow us to test against randomly generated cids
# note that the 10 is because the existing tests had some short all numeric cids
$got_body =~ s/cid:\d{10}\d+/cid:/g;
}
DUMP("test_mime", { expected => $exp_body, got => $got_body });
ASSERT(defined $got_body && $got_body eq $exp_body, "body");
}
}
# Actually send the mail
sub send_mail {
my $email = shift;
my $smtp_host = $ENV{SMTP_HOST} || 'localhost';
warn "SMTP_HOST env var not set in environment using 'localhost'\n" unless ($ENV{SMTP_HOST});
require Email::Send;
warn "Sending email to '$mailto'...\n";
if ( $Email::Send::VERSION < 2.0 ) {
my $rv = Email::Send::send('SMTP',$email, $smtp_host);
die $rv if ! $rv;
}
else {
my $sender = Email::Send->new({mailer => 'SMTP'});
$sender->mailer_args([Host => $smtp_host]);
my $rv = $sender->send($email);
die $rv if ! $rv;
}
}
#######################################################
#
# Simple in-memory cache for testing
#
#######################################################
package UnitTestCache;
sub new {
return bless({}, shift());
}
sub set {
my ($self, $key, $value) = @_;
$self->{$key} = $value;
}
sub get {
my ($self, $key) = @_;
return $self->{$key};
}
1;
Email-MIME-CreateHTML-1.030/lib/ 0000755 0165221 0000772 00000000000 11335311643 017176 5 ustar jamiel engineers 0000000 0000000 Email-MIME-CreateHTML-1.030/lib/Email/ 0000755 0165221 0000772 00000000000 11335311643 020225 5 ustar jamiel engineers 0000000 0000000 Email-MIME-CreateHTML-1.030/lib/Email/MIME/ 0000755 0165221 0000772 00000000000 11335311643 020754 5 ustar jamiel engineers 0000000 0000000 Email-MIME-CreateHTML-1.030/lib/Email/MIME/CreateHTML/ 0000755 0165221 0000772 00000000000 11335311643 022644 5 ustar jamiel engineers 0000000 0000000 Email-MIME-CreateHTML-1.030/lib/Email/MIME/CreateHTML/Resolver/ 0000755 0165221 0000772 00000000000 11335311643 024445 5 ustar jamiel engineers 0000000 0000000 Email-MIME-CreateHTML-1.030/lib/Email/MIME/CreateHTML/Resolver/Cached.pm 0000644 0165221 0000772 00000004706 11335311613 026156 0 ustar jamiel engineers 0000000 0000000 ###############################################################################
# Purpose : Apply caching to another resolver
# Author : John Alden
# Created : Aug 2006
# CVS : $Header: /home/cvs/software/cvsroot/email/lib/Email/MIME/CreateHTML/Resolver/Cached.pm,v 1.4 2006/08/24 21:41:38 johna Exp $
###############################################################################
package Email::MIME::CreateHTML::Resolver::Cached;
use strict;
use Data::Serializer;
use URI::Escape;
use vars qw($VERSION);
$VERSION = sprintf "%d.%03d", q$Revision: 1.4 $ =~ /: (\d+)\.(\d+)/;
sub new {
my ($class, $args) = @_;
my $self = {
'Resolver' => $args->{resolver},
'Cache' => $args->{object_cache},
'base' => $args->{base},
};
return bless($self, $class);
}
sub get_resource {
my ($self, $uri) = @_;
my $args = {'uri' => $uri, 'base' => $self->{base}, 'resolver' => ref $self->{Resolver}};
my $key = join('&', map {$_ . '=' . URI::Escape::uri_escape($args->{$_})} grep {defined $args->{$_}} sort(keys %$args));
my $cache = $self->{Cache};
my $serialized = $cache->get( $key );
my $ds = Data::Serializer->new();
my @rv;
if ( defined $serialized ) {
my $deserialized = $ds->deserialize( $serialized );
@rv = @$deserialized;
}
else {
@rv = $self->{Resolver}->get_resource( $uri );
my $serialized = $ds->serialize( \@rv );
$cache->set( $key,$serialized );
}
return @rv;
}
1;
=head1 NAME
Email::MIME::CreateHTML::Resolver::Cached - wraps caching around a resource resolver
=head1 SYNOPSIS
my $o = new Email::MIME::CreateHTML::Resolver::Cached(\%args)
my ($content,$filename,$mimetype,$xfer_encoding) = $o->get_resource($uri)
=head1 DESCRIPTION
This is used by Email::MIME::CreateHTML to load resources.
=head1 METHODS
=over 4
=item $o = new Email::MIME::CreateHTML::Resolver::Cached(\%args)
%args can contain:
=over 4
=item base
Base URI to resolve URIs passed to get_resource.
=item object_cache (mandatory)
A cache object
=item resolver (mandatory)
Another resolver to apply caching to
=back
=item ($content,$filename,$mimetype,$xfer_encoding) = $o->get_resource($uri)
=back
=head1 VERSION
$Revision: 1.4 $ on $Date: 2006/08/24 21:41:38 $ by $Author: johna $
=head1 AUTHOR
Tony Hennessy, Simon Flack and John Alden
=head1 COPYRIGHT
(c) BBC 2005,2006. This program is free software; you can redistribute it and/or modify it under the GNU GPL.
See the file COPYING in this distribution, or http://www.gnu.org/licenses/gpl.txt
=cut
Email-MIME-CreateHTML-1.030/lib/Email/MIME/CreateHTML/Resolver/LWP.pm 0000644 0165221 0000772 00000006607 11335311613 025453 0 ustar jamiel engineers 0000000 0000000 ###############################################################################
# Purpose : Load resources using LWP
# Author : John Alden
# Created : Aug 2006
# CVS : $Header: /home/cvs/software/cvsroot/email/lib/Email/MIME/CreateHTML/Resolver/LWP.pm,v 1.7 2006/08/24 21:41:38 johna Exp $
###############################################################################
package Email::MIME::CreateHTML::Resolver::LWP;
use strict;
use Carp;
use MIME::Types;
use LWP::UserAgent;
use vars qw($VERSION);
$VERSION = sprintf "%d.%03d", q$Revision: 1.7 $ =~ /: (\d+)\.(\d+)/;
sub new {
my ($class, $options) = @_;
$options ||= {};
my $ua = LWP::UserAgent->new(agent => __PACKAGE__);
$ua->env_proxy;
# Stop us getting cached resources when they have been updated on the server
$ua->default_header( 'Cache-Control' => 'no-cache' );
$ua->default_header( 'Pragma' => 'no-cache' );
my $self = {
%$options,
'UA' => $ua,
};
return bless($self, $class);
}
#Resource loader using LWP
sub get_resource {
my ($self, $src) = @_;
my $base = $self->{base};
#Resolve URIs relative to optional base URI
my $uri;
if(defined $base) {
require URI::WithBase;
$uri = URI::WithBase->new_abs( $src, $base );
} else {
$uri = new URI($src);
}
#Fetch resource from URI using LWP
my $response = $self->{UA}->get($uri->as_string);
croak( "Could not fetch ".$uri->as_string." : ".$response->status_line ) unless ($response->is_success);
my $content = $response->content;
DUMP("HTTP response", $response);
#Filename
my $path = $uri->path;
my ($volume,$directories,$filename) = File::Spec->splitpath( $path );
#Deduce MIME type and transfer encoding
my ($mimetype, $encoding);
if(defined $filename && length($filename)) {
TRACE("Using file extension to deduce MIME type and transfer encoding");
($mimetype, $encoding) = MIME::Types::by_suffix($filename);
} else {
$filename = 'index';
}
#If we have a content-type header we can make a more informed guess at MIME type
if ($response->header('content-type')) {
$mimetype = $response->header('content-type');
TRACE("Content Type header: $mimetype");
$mimetype = $1 if($mimetype =~ /(\S+);\s*charset=(.*)$/); #strip down to just a MIME type
}
#If all else fails then some conservative and general-purpose defaults are:
$mimetype ||= 'application/octet-stream';
$encoding ||= 'base64';
#Return values expected from a resource callback
return ($content, $filename, $mimetype, $encoding);
}
sub TRACE {}
sub DUMP {}
1;
=head1 NAME
Email::MIME::CreateHTML::Resolver::LWP - uses LWP as a resource resolver
=head1 SYNOPSIS
my $o = new Email::MIME::CreateHTML::Resolver::LWP(\%args)
my ($content,$filename,$mimetype,$xfer_encoding) = $o->get_resource($uri)
=head1 DESCRIPTION
This is used by Email::MIME::CreateHTML to load resources.
=head1 METHODS
=over 4
=item $o = new Email::MIME::CreateHTML::Resolver::LWP(\%args)
%args can contain:
=over 4
=item base
Base URI to resolve URIs passed to get_resource.
=back
=item ($content,$filename,$mimetype,$xfer_encoding) = $o->get_resource($uri)
=back
=head1 VERSION
$Revision: 1.7 $ on $Date: 2006/08/24 21:41:38 $ by $Author: johna $
=head1 AUTHOR
Tony Hennessy, Simon Flack and John Alden
=head1 COPYRIGHT
(c) BBC 2005,2006. This program is free software; you can redistribute it and/or modify it under the GNU GPL.
See the file COPYING in this distribution, or http://www.gnu.org/licenses/gpl.txt
=cut Email-MIME-CreateHTML-1.030/lib/Email/MIME/CreateHTML/Resolver/Filesystem.pm 0000644 0165221 0000772 00000005227 11335311613 027132 0 ustar jamiel engineers 0000000 0000000 ###############################################################################
# Purpose : Load resources from the filesystem
# Author : John Alden
# Created : Aug 2006
# CVS : $Header: /home/cvs/software/cvsroot/email/lib/Email/MIME/CreateHTML/Resolver/Filesystem.pm,v 1.6 2006/08/24 21:41:38 johna Exp $
###############################################################################
package Email::MIME::CreateHTML::Resolver::Filesystem;
use strict;
use URI::file;
use File::Slurp::WithinPolicy 'read_file';
use MIME::Types;
use File::Spec;
use vars qw($VERSION);
$VERSION = sprintf "%d.%03d", q$Revision: 1.6 $ =~ /: (\d+)\.(\d+)/;
sub new {
my ($class, $options) = @_;
$options ||= {};
my $self = {%$options};
return bless($self, $class);
}
#Simple/secure resource loader from local filesystem
sub get_resource {
my ($self, $uri) = @_;
my $base = $self->{base};
#Handle file:// URIs if necessary
my ($path, $base_dir) = map {defined && m|^file://|? URI::file->new($_)->file() : $_} ($uri, $base);
#Allow for base dir
my $fullpath = defined($base_dir) ? File::Spec->catfile($base_dir,$path) : $path;
#Read in the file
my $content = read_file($fullpath);
my ($volume,$directories,$filename) = File::Spec->splitpath( $path );
#Deduce MIME type/transfer encoding (currently using extension)
#We may want to improve the sophistication of this (e.g. making use of $content)
my ($mimetype,$encoding) = MIME::Types::by_suffix($filename);
return ($content,$filename,$mimetype,$encoding);
}
1;
=head1 NAME
Email::MIME::CreateHTML::Resolver::Filesystem - finds resources via the filesystem
=head1 SYNOPSIS
my $o = new Email::MIME::CreateHTML::Resolver::Filesystem(\%args)
my ($content,$filename,$mimetype,$xfer_encoding) = $o->get_resource($uri)
=head1 DESCRIPTION
This is used by Email::MIME::CreateHTML to load resources.
=head1 METHODS
=over 4
=item $o = new Email::MIME::CreateHTML::Resolver::Filesystem(\%args)
%args can contain:
=over 4
=item base
Base directory used to resolve relative filepaths passed to get_resource.
=back
=item ($content,$filename,$mimetype,$xfer_encoding) = $o->get_resource($uri)
=back
=head1 TODO
- Currently the MIME type is deduced from the file extension via MIME::Types; given we have the content available, more sophisticated strategies are probably possible
=head1 VERSION
$Revision: 1.6 $ on $Date: 2006/08/24 21:41:38 $ by $Author: johna $
=head1 AUTHOR
Tony Hennessy, Simon Flack and John Alden
=head1 COPYRIGHT
(c) BBC 2005,2006. This program is free software; you can redistribute it and/or modify it under the GNU GPL.
See the file COPYING in this distribution, or http://www.gnu.org/licenses/gpl.txt
=cut Email-MIME-CreateHTML-1.030/lib/Email/MIME/CreateHTML/Resolver.pm 0000644 0165221 0000772 00000010243 11335311613 025000 0 ustar jamiel engineers 0000000 0000000 ###############################################################################
# Purpose : Pick the most appropriate resolver
# Author : John Alden
# Created : Aug 2006
# CVS : $Header: /home/cvs/software/cvsroot/email/lib/Email/MIME/CreateHTML/Resolver.pm,v 1.5 2006/08/24 21:41:38 johna Exp $
###############################################################################
package Email::MIME::CreateHTML::Resolver;
use strict;
use Carp;
use vars qw($VERSION $HaveCache $HaveLWP $HaveFilesystem);
$VERSION = sprintf "%d.%03d", q$Revision: 1.5 $ =~ /: (\d+)\.(\d+)/;
$HaveCache = 0;
eval {
require Email::MIME::CreateHTML::Resolver::Cached;
$HaveCache = 1;
};
$HaveLWP = 0;
eval {
require Email::MIME::CreateHTML::Resolver::LWP;
$HaveLWP = 1;
};
$HaveFilesystem = 0;
eval {
require Email::MIME::CreateHTML::Resolver::Filesystem;
$HaveFilesystem = 1;
};
#
# API
#
sub new {
my ($class, $args) = @_;
$args ||= {};
#Do some sanity checking of inputs
my $resolver = $args->{resolver};
if(defined $resolver) {
confess "resolver must be an object" unless ( UNIVERSAL::isa($resolver,'UNIVERSAL') );
confess "resolver does not seem to use the expected interface (get_resource)" unless ($resolver->can('get_resource'));
}
my $object_cache = $args->{'object_cache'};
if(defined $object_cache ) {
confess "object_cache must be an object" unless ( UNIVERSAL::isa($object_cache,'UNIVERSAL') );
confess "object_cache does not seem to use the expected cache interface (get and set methods)"
unless ($object_cache->can('get') && $object_cache->can('set'));
warn("Caching support is not available - object_cache will not be used") unless($HaveCache);
}
#Construct object
my $self = bless ({
%$args
}, $class);
return $self;
}
sub get_resource {
my ($self, $uri) = @_;
croak("get_resource without a URI") unless(defined $uri && length($uri));
my $resolver = $self->_select_resolver($uri);
return $resolver->get_resource($uri);
}
#
# Private methods
#
sub _select_resolver {
my ($self, $uri) = @_;
#Look at the start of the URI
my $start = (defined $self->{base} && length($self->{base}))? $self->{base} : $uri;
#Pick an appropriate resolver...
my $resolver;
if($self->{resolver}) {
#If we've been told to use a specific resolver we'll respect that
$resolver = $self->{resolver};
} else {
#Decide on the best resolver to use - does URL start with protocol://
TRACE("Start is $start");
if($HaveFilesystem && $start =~ /^file:\/\//){
#Push file URLs through filesystem resolver if available (so File::Policy gets applied)
$resolver = new Email::MIME::CreateHTML::Resolver::Filesystem($self);
} elsif($start =~ /^\w+:\/\//) {
die("External URLs in emails cannot be resolved without the LWP resolver (which is currently not installed)\n") unless($HaveLWP);
$resolver = new Email::MIME::CreateHTML::Resolver::LWP($self);
} else {
die("Local URLs in emails cannot be resolved without the Filesystem resolver (which is currently not installed)\n") unless($HaveFilesystem);
$resolver = new Email::MIME::CreateHTML::Resolver::Filesystem($self);
}
}
#Optionally wrap it with caching
if($HaveCache && defined $self->{'object_cache'} ) {
$resolver = new Email::MIME::CreateHTML::Resolver::Cached({resolver => $resolver, object_cache => $self->{'object_cache'}});
}
return $resolver;
}
sub TRACE {}
sub DUMP {}
1;
=head1 NAME
Email::MIME::CreateHTML::Resolver - provides the appropriate resource resolver
=head1 SYNOPSIS
my $o = new Email::MIME::CreateHTML::Resolver(\%args)
my ($content,$filename,$mimetype,$xfer_encoding) = $o->get_resource($uri)
=head1 DESCRIPTION
This is used by Email::MIME::CreateHTML to load resources.
=head1 METHODS
=over 4
=item $o = new Email::MIME::CreateHTML::Resolver(\%args)
=item ($content,$filename,$mimetype,$xfer_encoding) = $o->get_resource($uri)
=back
=head1 VERSION
$Revision: 1.5 $ on $Date: 2006/08/24 21:41:38 $ by $Author: johna $
=head1 AUTHOR
Tony Hennessy, Simon Flack and John Alden
=head1 COPYRIGHT
(c) BBC 2005,2006. This program is free software; you can redistribute it and/or modify it under the GNU GPL.
See the file COPYING in this distribution, or http://www.gnu.org/licenses/gpl.txt
=cut
Email-MIME-CreateHTML-1.030/lib/Email/MIME/CreateHTML.pm 0000644 0165221 0000772 00000050260 11335311613 023202 0 ustar jamiel engineers 0000000 0000000 ###############################################################################
# Purpose : Build HTML emails
# Author : Tony Hennessy
# Created : Aug 2006
# CVS : $Header: /home/cvs/software/cvsroot/email/lib/Email/MIME/CreateHTML.pm,v 1.30 2010/02/12 17:44:26 jamiel Exp $
###############################################################################
package Email::MIME::CreateHTML;
use strict;
use Carp;
use Exporter;
use Email::MIME;
use HTML::TokeParser::Simple;
use HTML::Tagset;
use Email::MIME::CreateHTML::Resolver;
#Globals
use vars qw($VERSION %EMBED @EXPORT_OK @ISA);
$VERSION = sprintf "%d.%03d", q$Revision: 1.30 $ =~ /: (\d+)\.(\d+)/;
%EMBED = (
'bgsound' => {'src'=>1},
'body' => {'background'=>1},
'img' => {'src'=>1},
'input' => {'src'=>1},
'table' => {'background'=>1},
'td' => {'background'=>1},
'th' => {'background'=>1},
'tr' => {'background'=>1},
);
@EXPORT_OK = qw(embed_objects parts_for_objects build_html_email);
@ISA = qw(Exporter);
#
# Public routines used by create_html and also exportable
#
sub embed_objects {
my ($html, $args) = @_;
my $embed = ( defined $args->{embed} && $args->{embed} eq '0' ) ? 0 : 1;
my $inline_css = ( defined $args->{inline_css} && $args->{inline_css} eq '0' ) ? 0 : 1;
my $resolver = new Email::MIME::CreateHTML::Resolver($args);
my $embed_tags = $args->{'embed_elements'} || \%EMBED;
return ($html, {}) unless ( $embed || $inline_css ); #No-op unless one of these is set
my ($html_modified, %embedded_cids);
my $parser = HTML::TokeParser::Simple->new( \$html );
my $regex = '^(' . join('|',keys %HTML::Tagset::linkElements) . ')';
$regex = qr/$regex/;
while ( my $token = $parser->get_token ) {
unless ( $token->is_start_tag( $regex ) ) {
$html_modified .= $token->as_is;
next;
}
my $token_tag = $token->get_tag();
my $token_attrs = $token->get_attr();
# inline_css
if ( $token_tag eq 'link' && $token_attrs->{type} eq 'text/css' ) {
unless ( $inline_css ) {
$html_modified .= $token->as_is;
next;
}
my $link = $token_attrs->{'href'};
my ($content,$filename,$mimetype,$encoding) = $resolver->get_resource( $link );
$html_modified .= "\n".'\n";
next;
}
# rewrite and embed
for my $attr ( @{ $HTML::Tagset::linkElements{$token_tag} } ) {
if ( defined $token_attrs->{$attr} ) {
my $link = $token_attrs->{$attr};
next if ($link =~ m/^cid:/i);
# embed
if ( $embed && $embed_tags->{$token_tag}->{$attr} ) {
unless ( defined $embedded_cids{$link} ) {
# make a unique cid
my $newcid = time().$$.int(rand(1e6));
$embedded_cids{$link} = $newcid;
}
my $link_rewrite = "cid:".$embedded_cids{$link};
$token->set_attr( $attr => $link_rewrite );
}
}
}
$html_modified .= $token->as_is;
}
my %objects = reverse %embedded_cids; #invert mapping
return ($html_modified, \%objects);
}
sub parts_for_objects {
my ($objects, $args) = @_;
my $resolver = new Email::MIME::CreateHTML::Resolver($args);
my @html_mime_parts;
foreach my $cid (keys %$objects) {
croak "Content-Id '$cid' contains bad characters" unless ($cid =~ m/^[\w\-\@\.]+$/);
croak "Content-Id must be given" unless length($cid);
my $path = $objects->{$cid};
my ($content,$filename,$mimetype,$encoding) = $resolver->get_resource( $path );
$mimetype ||= 'application/octet-stream';
my $newpart = Email::MIME->create(
attributes => {
content_type => $mimetype,
encoding => $encoding,
disposition => 'inline', # maybe useful rfc2387
charset => undef,
name => $filename,
},
body => $content,
);
$newpart->header_set('Content-ID',"<$cid>");
# $newpart->header_set("Content-Transfer-Encoding", "base64");
push @html_mime_parts , $newpart;
}
return @html_mime_parts;
}
sub build_html_email {
my($header, $html, $body_attributes, $html_mime_parts, $plain_text_mime) = @_;
my $email;
if ( ! scalar(@$html_mime_parts) && ! defined($plain_text_mime) ) {
# HTML, no embedded objects, no text alternative
$email = Email::MIME->create(
header => $header,
attributes => $body_attributes,
body => $html,
);
}
elsif ( ! scalar(@$html_mime_parts) && defined($plain_text_mime) ) {
# HTML, no embedded objects, with text alternative
$email = Email::MIME->create(
header => $header,
attributes => {content_type=>'multipart/alternative'},
parts => [
$plain_text_mime,
Email::MIME->create(
attributes => $body_attributes,
body => $html,
),
],
);
}
elsif ( scalar(@$html_mime_parts) && ! defined($plain_text_mime) ) {
# HTML with embedded objects, no text alternative
$email = Email::MIME->create(
header => $header,
attributes => {content_type=>'multipart/related'},
parts => [
Email::MIME->create(
attributes => $body_attributes,
body => $html,
),
@$html_mime_parts,
],
);
}
elsif ( scalar(@$html_mime_parts) && defined($plain_text_mime) ) {
# HTML with embedded objects, with text alternative
$email = Email::MIME->create(
header => $header,
attributes => {content_type=>'multipart/alternative'},
parts => [
$plain_text_mime,
Email::MIME->create(
attributes => {content_type=>'multipart/related'},
parts => [
Email::MIME->create(
attributes => $body_attributes,
body => $html,
),
@$html_mime_parts,
],
),
],
);
}
return $email;
}
# Add to Email::MIME
package Email::MIME;
use strict;
use Carp;
use Email::MIME::Creator;
sub create_html {
my ($class, %args) = @_;
#Argument checking/defaulting
my $html = $args{body} || croak "You must supply a body";
my $objects = $args{'objects'} || undef;
# Make plain text Email::MIME object, we will never use this alone so we don't need the headers
my $plain_text_mime;
if ( exists($args{text_body}) ) {
my %text_body_attributes = ( (content_type=>'text/plain'), %{$args{text_body_attributes} || {}} );
$plain_text_mime = $class->create(
attributes => \%text_body_attributes,
body => $args{text_body},
);
}
# Parse the HTML and create a CID mapping for objects to embed
my $embedded_cids;
($html, $embedded_cids) = Email::MIME::CreateHTML::embed_objects($html, \%args);
# Create parts for each embedded object
my @html_mime_parts;
push @html_mime_parts, Email::MIME::CreateHTML::parts_for_objects($objects, \%args) if ($objects);
push @html_mime_parts, Email::MIME::CreateHTML::parts_for_objects($embedded_cids, \%args) if(%$embedded_cids);
# Create the mail
my $header = $args{header};
my %body_attributes = ( (content_type=>'text/html'), %{$args{body_attributes} || {}});
my $email = Email::MIME::CreateHTML::build_html_email($header, $html, \%body_attributes, \@html_mime_parts, $plain_text_mime);
return $email;
}
#Log::Trace stubs
sub DUMP {}
sub TRACE {}
1;
__END__
=pod
=head1 NAME
Email::MIME::CreateHTML - Multipart HTML Email builder
=head1 SYNOPSIS
use Email::MIME::CreateHTML;
my $email = Email::MIME->create_html(
header => [
From => 'my@address',
To => 'your@address',
Subject => 'Here is the information you requested',
],
body => $html,
text_body => $plain_text
);
use Email::Send;
my $sender = Email::Send->new({mailer => 'SMTP'});
$sender->mailer_args([Host => 'smtp.example.com']);
$sender->send($email);
=head1 DESCRIPTION
This module allows you to build HTML emails, optionally with a text-only alternative and embedded media objects.
For example, an HTML email with an alternative version in plain text and with all the required
images contained in the mail.
The HTML content is parsed looking for embeddable media objects. A resource loading routine is used to fetch content
from those URIs and replace the URIs in the HTML with CIDs. The default resource loading routine is deliberately conservative, only allowing resources to be fetched from the local filesystem. It's possible and relatively straightforward to plug in a custom resource loading routine that can resolve URIs using a broader range of protocols. An example of one using LWP is given later in the L.
The MIME structure is then assembled, embedding the content of the resources where appropriate. Note that this module does not send any mail, it merely does the work of building the appropriate MIME message. The message can be sent with L or any other mailer that can be fed a string representation of an email message.
=head2 Mail Construction
The mail construction is compliant with rfc2557.
HTML, no embedded objects (images, flash, etc), no text alternative
text/html
HTML, no embedded objects, with text alternative
multipart/alternative
text/plain
text/html
HTML with embedded objects, no text alternative
multipart/related
text/html
embedded object one
embedded object two
...
HTML with embedded objects, with text alternative
multipart/alternative
text/plain
multipart/related
text/html
embedded object one
embedded object two
...
=head1 METHODS
There is only one method, which is installed into the Email::MIME package:
=over 4
=item Email::MIME->create_html(%parameters)
This method creates an Email::MIME object from a set of named parameters.
Of these the C and C parameters are mandatory and all others are optional.
See the L section for more information.
=back
=head2 LOW-LEVEL API
Email::MIME::CreateHTML also defines a lower-level interface of 3 building-block routines that you can use for finer-grain construction of HTML mails.
These may be optionally imported:
use Email::MIME::CreateHTML qw(embed_objects parts_for_objects build_html_mail);
=over 4
=item ($modified_html, $cid_mapping) = embed_objects($html, \%options)
This parses the HTML and replaces URIs in the embed list with a CID.
The modified HTML and CID to URI mapping is returned.
Relevant parameters are:
embed
inline_css
base
object_cache
resolver
The meanings and defaults of these parameters are explained below.
=item @mime_parts = parts_for_objects($cid_mapping, \%options)
This creates a list of Email::MIME parts for each of the objects in the supplied CID mapping.
Relevant options are:
base
object_cache
resolver
The meanings and defaults of these parameters are explained below.
=item $email = build_html_email(\@headers, $html, \%body_attributes, \@html_mime_parts, $plain_text_mime)
The assembles a ready-to-send Email::MIME object (that can be sent with Email::Send).
=back
=head1 PARAMETERS
=over 4
=item header =E I
A list reference containing a set of headers to be created.
If no Date header is specified, one will be provided for you based on the
gmtime() of the local machine.
=item body =E I
A scalar value holding the HTML message body.
=item body_attributes =E I
This is passed as the attributes parameter to the C method (supplied by C) that creates the html part of the mail.
The body content-type will be set to C unless it is overidden here.
=item embed =E I
Attach relative images and other media to the message. This is enabled by default.
The module will attempt to embed objects defined by C.
Note that this option only affects the parsing of the HTML and will not affect the C option.
The object's URI will be rewritten as a Content ID.
=item embed_elements =E I
The set of elements that you want to be embedded. Defaults to the C<%Email::MIME::CreateHTML::EMBED> package global.
This should be a data structure of the form:
embed_elements => {
$elementname_1 => {$attrname_1 => $boolean_1},
$elementname_2 => {$attrname_2 => $boolean_2},
...
}
i.e. resource will be embedded if C<$embed_elements-E{$elementname}-E{$attrname}> is true.
=item resolver =E I
