File Coverage

lib/Email/MIME/CreateHTML.pm

Criterion	Covered	Total	%
statement	112	114	98.2
branch	41	46	89.1
condition	23	36	63.8
subroutine	15	17	88.2
pod	3	6	50.0
total	194	219	88.5

###############################################################################
# Purpose : Build HTML emails
# Author  : Tony Hennessy
# Created : Aug 2006
###############################################################################

package Email::MIME::CreateHTML;

use strict;
use Carp;
use Exporter;
use Email::MIME;
use HTML::TokeParser::Simple;
use HTML::Tagset;

our $VERSION = '1.041';

use Email::MIME::CreateHTML::Resolver;

#Globals
use vars qw(%EMBED @EXPORT_OK @ISA);
%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".'<!--'."\n". </td>
</tr>

<tr>
<td  class="h" >
<a name="70">70</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 							  $content. </td>
</tr>

<tr>
<td  class="h" >
<a name="71">71</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 							  "\n-->\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) = @_;

	$body_attributes->{charset} = 'UTF-8' unless exists $body_attributes->{charset};
	$body_attributes->{encoding}= 'quoted-printable' unless exists $body_attributes->{encoding};

	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_str => $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_str => $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_str => $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_str => $html,
						),
						@$html_mime_parts,
					],
				),
			],
		);
	}
	return $email;
}

# Add to Email::MIME
package # Hide from PAUSE
  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__