package HTML::Mail;

our $VERSION = '0.02_03';
$VERSION = eval $VERSION;    # see L<perlmodstyle>

# Preloaded methods go here.
use LWP::UserAgent;
use URI;
use HTML::Parser;
use MIME::Lite;
use Carp qw(carp croak);

use strict;
use warnings;

our @ISA = qw(HTML::Parser);

use vars qw($SIMPLE_CID $AUTOLOAD);

sub new {
	my ($package, %params) = @_;

	my $self = bless {}, $package;
	$self->{'_original_params'} = {};
	$self->{'_cache'}      = {};

	$self->build(%params);

	return $self;
}

#Default LWP::UserAgent

sub _set_default_lwp_ua {
	my $self = shift;
	$self->{'_ua'} ||= LWP::UserAgent->new(
		'agent'   => 'HTML::Mail',
		'timeout' => 60,
	);
	return $self;
}

sub build {
	my ($self, %params) = @_;

	$self->_reset_html;

	%params = (%{$self->{'_original_params'}}, %params);

	if (exists($params{'HTML'})) {
		$self->{'HTML'} = $params{'HTML'};
	}else {
		croak "No HTML parameter send";
	}
	if (exists($params{'Text'})) {
		$self->{'Text'} = $params{'Text'};
	}
	if ($params{'lwp_ua'}) {
		if($params{'lwp_ua'}->isa('LWP::UserAgent')){
			$self->{'_ua'} = $params{'lwp_ua'};
		}else{
			carp "lwp_ua attribute is not a LWP::UserAgent. Using default.";
		}
	}
	
	$self->{'inline_css'} = exists($params{'inline_css'}) ? 
		$params{'inline_css'} :
		1;

	#by default don't attach anything linked
	$self->{'attach_links'} = sub {return 0;};
	if(exists($params{'attach_links'})){
		if(ref($params{'attach_links'}) eq 'CODE'){
			$self->{'attach_links'} = $params{'attach_links'};
		}else{
			carp "attach_links specified but not a subroutine reference. Ignoring and using default.";
		}
	}

	$self->{'html_charset'} = $params{'html_charset'} || 'iso-8859-15';
	$self->{'text_charset'} = $params{'html_charset'} || 'iso-8859-15';

	$self->{'_original_params'} =  \%params;
	
	$self->_set_default_lwp_ua();
	
	$self->{'_message'} = MIME::Lite->new(
		%params,
		Type => $self->{'Text'} ? 
			'multipart/alternative' : 
			'multipart/related',
	);

	$self->_parse_html;
	if($self->{'Text'}) {
		$self->_attach_text;
	}
	$self->_attach_media;

	return $self;
}

sub _parse_html {
	my $self = shift;

	#set up the HTML parser
	$self->init(
		api_version => 3,
		start_h     => [\&_tag_start, 'self, tag, attr, attrseq'],
		end_h       => [\&_tag_end, 'self, tag, attr, attrseq'],
		text_h      => [\&_tag_end, 'self, text'],
	);

	my $content = $self->{'_cache'}->{$self->{'HTML'}};
	if(defined($content)){
		$self->parse($content);
		return $self;
	}

	my $response;
	eval { $response = $self->_get($self->{'HTML'}); };
	if ($@ or not ($response and $response->is_success)) {
		delete($self->{'_html_base'});
		if ($self->{'HTML'} =~ /<\s*html.*>/i) {
			$self->parse($self->{'HTML'});
		}else {
			die $@;
		}
	}
	else {
		$self->{'_html_base'} = $response->base();
		$self->{'_cache'}->{$self->{'HTML'}} = $response->content;
		$self->parse($response->content);
	}
	return $self;
}

#Return LWP::UserAgent used to make requests
#Allows user to fine tune options

sub lwp_ua{
	my ($self, $ua) = @_;
	
	if (ref($ua) && $ua->isa('LWP::UserAgent')){
		$self->{'_ua'} = $ua;
	}
	return $self->{'_ua'};
}

#Makes a GET request and returns the content

sub _get {
	my ($self, $uri) = @_;
	#warn "Getting $uri";

	if (!$self || !$self->{'_ua'}) {
		die "User agent not defined";
	}

	if (!$uri) {
		die "uri not defined";
	}

	my $response = $self->{'_ua'}->get($uri);

	if (!$response->is_success) {
		die "Error while making request [ GET ", $response->request->uri, "]\n", $response->status_line;
	}
	
	return $response;
}

sub _add_html {
	my ($self, $tag, $attr, $attrseq) = @_;
	my $content = \$self->{'html_content'};
	if ($#_ == 1) {
		$$content .= $tag;    #actually just text
		return;
	}

	#special treatment for tags that end with /
	my $empty;
	if($attr->{'/'} && $attr->{'/'} eq '/' && $attrseq){
		pop @$attrseq;
		$empty = 1;
	}

	$$content .= "<$tag";

	if ($attrseq && @$attrseq) {
		$$content .= qq/ $_="$attr->{$_}"/ for (@$attrseq);
	}
	else {
		while (my ($k, $v) = each(%$attr)) {
			$$content .= qq/ $k="$v"/;
		}
	}
	$$content .= " /" if $empty;
	$$content .= ">";
	return $self;
}

sub _get_html {
	return shift->{'html_content'};
}

sub _create_uri {
	my $self = shift;
	defined($_[0]) or die "need a link to create a uri";
	return URI->new_abs($_[0], $self->{'_html_base'});
}

sub _add_link {
	my $self = shift;

	my $uri = $self->_create_uri ($_[0]);

	if(!exists($self->{'links'}->{$uri}->[0])){
		my $cid = ($SIMPLE_CID ? '': int rand(10000)) . "_" . $self->{'cid'}++;
		$self->_get_media($uri, $cid);
	}

	return $self->{'links'}->{$uri}->[0];
}

sub _get_inline_content {
	my $self = shift;

	my $uri = $self->_create_uri ($_[0]);
	return $self->{'inline_links'}->{$uri} ||= $self->_get($uri)->content;
}

sub _get_links {
	return shift->{'links'} || {};;
}

sub _reset_links {
	my $self = shift;
	$self->{'links'} = {};
	$self->{'inline_links'} = {};
	$self->{'cid'} = 0;
	return $self;
}

sub _reset_html {
	shift->{'html_content'} = '';
}

sub _tag_start {
	my $self = shift;
	my ($tag, $attr, $attrseq) = @_;

	if ($tag eq 'base' and not $self->{'_html_base'}) {
		$self->{'_html_base'} = $attr->{'href'};
	}elsif (
		($tag eq 'link') && 
		($attr->{'rel'}  && 
		$attr->{'rel'} eq 'stylesheet') && 
		exists($attr->{'href'})
	){
		if($self->{'inline_css'}){
			my $content = $self->_add_inline_content(@_);
			return;
		}else{
			$self->_tag_filter_link($attr, 'href');
		}
	}elsif($tag eq 'a' and defined($attr->{'href'})){
		$attr->{'href'} = URI->new_abs($attr->{'href'},$self->{'_html_base'});
	}
	$self->_tag_filter_link($attr, 'background');
	$self->_tag_filter_link($attr, 'src') if ($tag ne 'script');

	#selective attach of linked media
	if(defined($attr->{'href'})){
		if($self->{'attach_links'}->($attr->{'href'})){
			$self->_tag_filter_link($attr, 'href');
		}
	}
	$self->_add_html(@_);
	return $self;
}

sub _add_inline_content{
	my $self = shift;
	my ($tag, $attr) = @_;

	my $link = $attr->{'href'};
	my $content = $self->_get_inline_content($link);

	#try to make easy to generalise in the future
	#javascript and other things may one day be inlined
	if($tag eq 'link' && $attr->{'rel'} eq 'stylesheet'){
		$tag = 'style';
		delete($attr->{'href'});
	}

	$self->_add_html($tag, $attr);
	$self->{'html_content'} .= "\n $content \n</$tag>";
	return $self;
}

sub _tag_filter_link {
	my ($self, $attrs, $attr) = @_;
	if (exists($attrs->{$attr})) {
		my $link = $attrs->{$attr};
		$attrs->{$attr} = "cid:" . $self->_add_link($link);
	}
	return $self;
}

sub _tag_end {
	shift->_add_html(@_);
}

sub _tag_text {
	shift->_add_html(@_);
}

sub _attach_media {
	my $self = shift;

    my $related;
	
	if($self->{'Text'}) {
		$related = MIME::Lite->new(
			'Type'        => 'multipart/related',
			'Datestamp'   => undef,
			'Disposition' => 'inline',
		);
	}else{
		$related = $self->{'_message'};
	}

    my $html_part = MIME::Lite->new(
        'Type'        => 'text/html',
        'Encoding'    => 'quoted-printable',
        'Data'        => $self->_get_html,
        'Disposition' => 'inline',
        'Datestamp'   => undef,
    );

	$html_part->attr('content-type.charset' => $self->{'html_charset'});

	#attach the html part
	$related->attach($html_part);

	if($SIMPLE_CID){
		#needs to be sorted in order to run the build tests
		#otherwise the order depends on the hashing function and threrefore on perl's version
		#TODO beter tests
		my %links = %{ $self->_get_links };
		for (sort keys %links) {
			$related->attach($links{$_}->[1]);
		}
	}else{
		while ( my ( $link, $media ) = each( %{ $self->_get_links } ) ) {
			$related->attach( $media->[1] );
		}
	}

	if($self->{'Text'}){
		$self->{'_message'}->attach($related);
	}
	return $self;
}

sub _get_media {
	my ($self, $uri, $cid) = @_;

	my $response = $self->_get($uri);

	my $part = MIME::Lite->new(
	  'Encoding'    => 'base64',
	  'Disposition' => 'attachment',
	  'Data'        => $response->content,
	  'Datestamp'   => undef,
	);

	$part->attr('Content-type' => $response->content_type);
	$part->attr('Content-ID'   => "<$cid>");

	$self->{'links'}->{$uri} = [$cid, $part];
	return $self;
}

sub _attach_text {
	my $self    = shift;
	my $text    = $self->{'Text'};
	my $content = $self->{'_cache'}->{$text};

	if(!defined($content)){
		eval { $content = $self->_get($text)->content; };
		if($@){
			$content = $text;
		}
		$self->{'_cache'}->{$text} = $content;
	}

    my $text_part = new MIME::Lite(
        'Type'        => 'TEXT',
        'Encoding'    => 'quoted-printable',
        'Disposition' => 'inline',
        'Data'        => $content,
        'Datestamp'   => undef,
    );
	$text_part->attr('content-type.charset' => $self->{'text_charset'});

	$self->{'_message'}->attach($text_part);
	return $self;
}

sub dump {
	require Data::Dumper;
	
	my $self = shift;
	return Data::Dumper->Dump([$self], [qw(html_mail_dump)]);
}

sub dump_file {
	my ($self, $fname) = @_;
	my $file;
	
	open $file, ">$fname" or croak "Error openning file $fname for writting.\n$!";
	print $file $self->dump;
	return $self;
}

sub restore {
	my (undef, $data) = @_;

	my $html_mail_dump;

	eval "$data";
	return $html_mail_dump;
}

sub restore_file {
	my ($package, $fname) = @_;
	my $file;
	
	open $file, "<$fname" or croak "Error openning file $fname for reading.\n$!";
	{
		local $/;
		my $data = <$file>;
		return $package->restore($data);
	}
	return;
}

sub AUTOLOAD {
	my $self = shift;
	$AUTOLOAD =~ s/.*:://;
	if($self->{'_message'} && $self->{'_message'}->can($AUTOLOAD)){
		return $self->{'_message'}->$AUTOLOAD(@_);
	}
}

1;
__END__
# Below is stub documentation for your module. You'd better edit it!

=head1 NAME

HTML::Mail - Perl extension for sending emails with embedded  HTML and media

=head1 SYNOPSIS

	use HTML::Mail;

	### initialisation
	my $html_mail = HTML::Mail->new(
		HTML    => 'http://www.cpan.org',
		Text    => 'This is the text representation of the webpage http://www.cpan.org',
		From    => 'me@myhost.org',
		To      => 'you@yourhost.org',
		Subject => 'CPAN webpage');
	
	### Send the email ("inherited" from MIME::Lite)
	$html_mail->send();

	#### Remove text representation
	$html_mail->set_Text();
	
	### Rebuild the message and send
	$html_mail->build->send;

	### Serialise to file for later reuse
	$html_mail->dump_file('/tmp/cpan_mail.data');

	### Restore from file
	my $restored = HTML::Mail->restore_file('/tmp/cpan_mail.data');

=head1 DESCRIPTION

B<HTML::Mime> is supposed to help with the task of sending emails with HTML and images (or other media) embedded .
It uses L<MIME::Lite|MIME::Lite> for all MIME related jobs, L<HTML::Parser|HTML::Parser> to find related files and change the URIs and L<LWP::UserAgent|LWP::UserAgent> to retrieve the related files.

Email can be 'multipart/alternative' if both HTML and Text content exist and 'multipart/related' if there is only HTML content.

If you want to send text-only email, you probably won't find this module usefull at all.

=head2 Method Summary

=over 4

=item new

Constructor. 
Initialises the object.
See the L<attributes|/Attributes> section

=item build

Regenerates the email. Allows you to change any attributes as in the constructor.
Main difference with C<new> is that it doesn't fetch content that was previously fetched/parsed.

=item lwp_ua

Returns the L<LWP::UserAgent|LWP::UserAgent> object used internally so that it can the customised

=item dump

Serialises the object to a string

=item dump_file

Serialises the object to a file

=item restore

Restores previously serialised object

=item restore_file

Restores previously serialised object from a file

=back

=head2 Attributes

All attributes are B<case sensitive>.

	my $html_mail = HTML::Mail->new(attribute => value);

	$html_mail->build(attribute => value);

Constructor supports these attributes:

=over 4

=item HTML [URI or STRING]

The URL of HTML data to send in email.
Most common URLs are either F<http://www.site.org> or F<file:///home/user/page.html>

If you prefer, you can use it to specify the actual HTML data as a string 

	HTML=>'<html><body><h1>Welcome to HTML::Mail</h1></body></html>';

=item Text [URI or STRING]

The URL of Text data to send in email. Similar to the HTML attribute.

=item From, To, Subject

Inherited from L<MIME::Lite|MIME::Lite>. Sender, Recipient and Subject of the message.

=item html_charset

Charset of the HTML part of the email. Defaults to I<iso-8859-15>.

=item text_charset

Charset of the text part of the email. Defaults to I<iso-8859-15>.

=item lwp_ua

L<LWP::UserAgent|LWP::UserAgent> object used to retrieve documents.
The default agent has a 60 second timeout and sends I<HTML::Mail> as the agent.
See also L<ADVANCED USAGE|/ADVANCED USAGE>.

=item inline_css

A true value specifies that when the HTML uses external css this content be placed in the <style> tag at the header of the document, default value is true.

Don't change the default behaviour unless there is a very strong reason since most email clients won't interpret css unless they are in-lined.

=item attach_links

Controls which links are also included in the email. See L<Linked Media|/Linked Media>.

=back

=head1 ADVANCED USAGE

=head2 LWP::UserAgent options

The C<lwp_ua> method returns the instance of L<LWP::UserAgent|LWP::UserAgent> used to make the request.
Using this method you can change it's options to your needs.

	my $ua = LWP::UserAgent->new(%options);
	$html_mail->lwp_ua($ua);

	#or set the options after creation
	$html_mail->lwp_ua->timeout(10);

This is very useful for specifying proxies, cookie parameters, etc.
See L<LWP::UserAgent's manpage|LWP::UserAgent> for all the details.

=head2 Persistence

HTML::Mail objects are designed so that implementing persistence is easy.

The method C<dump> dumps the object as a string. You can store this string in whatever way you wish to and later restore the object with the C<restore> method. There exist also methods C<dump_file> and C<restore_file> that serialise and restore the objects to and from text files.

	### initialisation
	my $html_mail = HTML::Mail->new(
	HTML    => 'http://www.cpan.org',
	Text    => 'This is the text representation of the webpage http://www.cpan.org',
	From    => 'me@myhost.org',
	To      => 'you@yourhost.org',
	Subject => 'CPAN webpage');
	
	### Serialise to string
	my $serialised = $html_mail->dump;

	### Restore
	my $hmtl_mail_restored = HTML::Mail->restore($serialised);
	
	### Serialise to disk
	### If file exists, it's content will be erased
	my $file = '/tmp/stored_html_mail.data';
	$html_mail->dump_file($file);

	### Restore from file
	my $hmtl_mail_restored = HTML::Mail->restore_file($file);
	
None of these methods are meant for speed.
Be also careful when restoring data that you don't trust since these methods basically use C<eval> to restore the objects.

All relevant data is stored, so you can send a restored email without fetching content again, or doing any HTML parsing if it was done before storing it.

=head2 Rebuilding emails

As of version  0.02_00 the job of reusing an object to send several emails is optimised.
This is mainly due to the fact that if the HTML content is changed, media that was included on the previous build will no longer be fetched and processed. However if there is new media referred to by the new HTML content, it will be fetched and made available for next builds.

This is particular useful for building customisable email campaigns, say putting the customer's name in the content. 

The parsing of the HTML content is always done.

	$html_mail->build(attribute => value)

regenerates the email. The attributes and values are the same as the ones in the C<new> method.

The default values are merged in each build meanings that new attributes are sticky. The default value of an attribute is the most recent one specified or the classes default

=head2 Linked Media

attach_links is a subroutine that determines which links will be included in the email. Gets as the argument the C<href> attribute of the tag and is expected to return a C<boolean>, a true return value includes the link a false value doesn't.

	#$html_mail is supposed to have been constructed for the sake of simplicity
	$html_mail->build(attach_links => 
		sub{
			my $link = shift;
			return $link =~ /\.pdf$/
		}
	)

	#This would include all links to pdf documents in the html

By default no links are included.

B<Be aware that a lot of email clients don't cope well with internally linked media>
B<This interface is considered experimental and subject to change, use at your own risk>

=head1 COMPATIBILITY

=head2 Sending email

This module uses L<MIME::Lite|MIME::Lite> to send the emails.
The default behaviour of the C<send> method is to use sendmail, if this is not possible try sending the mail using smtp.
C<<$html_mail->send('smtp','smtp_server.org')>>.
Please consult the documentation for further details.

=head2 Suggestions

Try to use only correct HTML, at least it should be well formed.

In-line CSS in HTML documents gives better results with a wider range of email clients.

Don't use Javascript, this module will not include external javascript.

this module doesn't support frames/iframes so don't use them for now.

=head2 Email Clients

Reports on how clients display emails generated using this module are very welcome.
Successfull/unsuccessful stories also welcome.

See the author's email at the end.

=over 4

=item Evolution 1.08

Full compatibility except for some CSS problems.

=item Kmail 1.4.3

HTML OK but usually displays both text and HTML parts with the images as attachments

=item Yahoo webmail (http://mail.yahoo.com)

HTML is shown, not text and all media is ok.

=item Hotmail (http://www.hotmail.com)

Unknown (reports welcome)

=item Outlook Express 6

HTML is shown. When the user prefers text, text content is shown together with a text rendering of the HTML.

=item Eudora

Unknown (reports welcome)

=back

=head1 EXPORT

None.

=head1 SEE ALSO

L<MIME::Lite|MIME::Lite> (this module "inherits" from it)

L<HTML::Parser|HTML::Parser> (used in this module to parse HTML)

L<LWP::UserAgent|LWP::UserAgent> (used to fetch content)

The F<eg> directory for some examples on how to use the package

=head1 DEVELOPMENT STATUS

Now considered alpha.

=head1  TODO LIST

=over 4

=item Tests

better tests at install time

=item Cid generation

more robust, try using something like uuidgen

=back

=head1 AUTHOR

Cláudio Valente, E<lt>plank@cpan.orgE<gt>

=head1 Bug Reporters

I would like to thank the help of:

=over 4

=item Matthew Albright

for bug reporting and submitting a patch

=item Daniel Wijnands

for bug reporting related with email rebuilding

=item Calvin Huang

for reporting a bug with relative links and several limitations regarding frames and iframes

=back


=head1 COPYRIGHT AND LICENSE

Copyright 2003 by Cláudio Valente

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. 

=cut
