File Coverage

lib/Petal/Mail.pm

Criterion	Covered	Total	%
statement	142	143	99.3
branch	36	40	90.0
condition	20	24	83.3
subroutine	21	21	100.0
pod	2	2	100.0
total	221	230	96.0

=head1 NAME

Petal::Mail - Format text e-mail using Petal


=head1 SYNOPSIS

  use Petal::Mail;
  use Petal::Mail;
  use Petal::Mail;
  use Petal::Mail;
  my $petal_mail = new Petal::Mail ('email.xml');
  my $text_mail  = $petal_mail->process (%args);


=head1 SUMMARY

L processes a Petal XML template, and then turns the resulting XML
into a text email which can be sent through sendmail or other. The XML has to
follow a certain syntax which is defined in this documentation.

Since L's is a subclass of Petal, its API is the same. Which
means you need to read about L before you can use L.

=cut
package Petal::Mail;
use strict;
use warnings;
use MKDoc::XML::TreeBuilder;
use MKDoc::XML::Decode;
use Encode;
use base qw /Petal/;


=head1 GLOBAL / LOCAL VARIABLES

=head2 local $Petal::Mail::Line_Wrap = 68;

Amounts of characters allowed before text-flowed wrapping.

=head2 local $Petal::Mail::Indent = 4;

Amounts of whitespace when indenting  tags

=head2 local $Petal::Mail::Sendmail = '/usr/sbin/sendmail -t';

If you set this variable to your sendmail executable, and make sure the
$ENV{SERVER_ADMIN} is set to a proper email address for processing bounces,
then you can use the send() method instead of the process() method and
Petal::Mail will send the email once it's been created.

=cut
our $Line_Wrap = 68;
our $DD_Indent = 4;
our $Sendmail  = '/usr/sbin/sendmail -t';


# can't touch those
our $Decode    = new MKDoc::XML::Decode qw/xml xhtml numeric/;

=head1 FUNCTIONS

=head2 process

This function processes a template. It takes a hash or hashref which is used
to fill out any elements in the template. It returns the processed template as
a string. See L for further details.

=cut
our $VERSION   = 0.31;

=head1 FUNCTIONS

=head2 process

This function processes a template. It takes a hash or hashref which is used
to fill out any elements in the template. It returns the processed template as
a string. See L for further details.
=head2 send

This function processes a template and sends an email message according to the
headers in the template.  It takes the same parameters as process in addition
to the email address of the authorized sender. The authorized sender may also
be set with the environment parameter 'SERVER_ADMIN'. Returns null on success
or dies on failure.

	$petal_mail->send(AUTH_SENDER => '[e-mail]', %args);

=cut

=cut

=head1 FUNCTIONS

=head2 process

This function processes a template. It takes a hash or hashref which is used
to fill out any elements in the template. It returns the processed template as
a string. See L for further details.
=head2 send

This function processes and sends an email message according to a template.
It takes the same parameters as process. Returns null(?) on success or dies on
failure.

=cut

=head1 FUNCTIONS

=head2 process

This function processes a template. It takes a hash or hashref which is used
to fill out any elements in the template. It returns the processed template as
a string. See L for further details.
=head2 send

This function processes and sends an email message according to a template.
It takes the same parameters as process. Returns null(?) on success or dies on
failure.

=cut

sub process
{
    my $self = shift;
    my $xml  = $self->SUPER::process (@_);
    return $self->_xml_to_text ($xml);
}


=head2 send

This function processes and sends an email message according to a template.
It takes the same parameters as process. Returns null(?) on success or dies on
failure.

=cut
sub send
{
    my $self = shift;
    my %args = @_;
    my $authorized_sender = $args{'AUTH_SENDER'} || $ENV{SERVER_ADMIN} || '';
    delete $args{'AUTH_SENDER'};
    $authorized_sender || die 'No authorized sender defined and $ENV{SERVER_ADMIN} not set';

    my $mail = $self->process (%args)                    || die '$self->process (\@_) returned undef';
    open (SENDMAIL, "| $Sendmail -f $authorized_sender") || die "error opening sendmail [$Sendmail]: $!";
    binmode (SENDMAIL, ":utf8");
    print SENDMAIL $mail                                 || die "error writing to sendmail [$Sendmail]: $!";
    close SENDMAIL;
}


sub _xml_to_text
{
    my $self   = shift;
    my $xml    = shift;

    my @nodes  = MKDoc::XML::TreeBuilder->process_data ($xml);
    my @result = map {
	((ref $_) and ($_->{_tag} eq 'Message')) ?
	$self->__Message ($_) : ()
    } @nodes;

    return join "\n", @result;
}


sub __Message
{
    my $self    = shift;
    my $node    = shift;

    my $headers = $self->__Headers ($node);
    my $body    = $self->__Body    ($node);
    return join "\n\n", ($headers, $body);
}


sub __Headers
{
    my $self = shift;
    my $node = shift;
    my @res  = map {
	(ref $_ and $_->{_tag} !~ /^body$/i) ? do {
    	    my $text = $self->__Content_To_Text ($_);
	    $text = $Decode->process ($text);
	    $text =~ s/\n/ /gsm;
	    $text = encode ('MIME-Header', $text);

	    my $tag  = $_->{_tag};
	    ($tag =~ /^from$/i) ?
	        ("$tag: $text", $self->__Headers_message_id ($text)) :
		("$tag: $text");
	} : ()
    } @{$node->{_content}};

    my $res  = join "\n", @res;
    return $res;
}


sub __Headers_message_id
{
    my $self = shift;
    my $id   = shift;
    my $time = time();
    my $rand = join '', map { chr (ord ('A') + int rand (26)) } 1..5;
    $id      =~ s/^.*
    $id      =~ s/>.*$//;
    $id      =~ s/^\s+//;
    $id      =~ s/\s+$//;
    $id      =~ s/^.*\@//;
    $id      = "$time.$rand\@$id";
    return qq |Message-ID: <$id>|;
}


sub __Content_To_Text
{
    my $self = shift;
    my $node = shift;
    my @res  = map {
	(ref $_) ? ( $self->__Content_To_Text ($_) ) : ( $Decode->process ($_) )
    } @{$node->{_content}};
    return join '', @res;
}


sub __Body
{
    my $self = shift;
    my $node = shift;
    my @res  = map {
	(ref $_ and $_->{_tag} =~ /^body$/i) ?
	$self->__Body_Process ($_) : ()
    } @{$node->{_content}};

    my $res = join "\n", @res;
    $res =~ s/^\n+//gs;
    return $res;
}


sub __Body_Process
{
    my $self = shift;
    my $node = shift;

    my @res  = map {
	my $node = $_;
	$self->__Body_P   ($node) ||
	$self->__Body_DT  ($node) ||
	$self->__Body_DD  ($node) ||
	$self->__Body_PRE ($node) ||
	do { ref ($_) ? ( $self->__Body_Process ($node) ) : () }
    } @{$node->{_content}};

    my $res  = join '', @res;
    return $res;
}


sub __Body_PRE
{
    my $self = shift;
    my $node = shift;

    ref $node || return;
    return unless ($node->{_tag} =~ /^pre$/i);

    my $text = $self->__Content_To_Text ($node);
    return "\n\n$text";
}


sub __Body_P
{
    my $self = shift;
    my $node = shift;

    ref $node || return;
    return unless ($node->{_tag} =~ /^p$/i);

    my $text = $self->__Content_To_Text ($node);
    $text =~ s/\n/ /gsm;
    $text =~ s/^\s+//;
    $text =~ s/\s+$//;

    my @tokens = split /\s+/, $text;
    return "\n\n" . $self->_soft_wrap (@tokens);
}


sub __Body_DT
{
    my $self = shift;
    my $node = shift;

    ref $node || return;
    return unless ($node->{_tag} =~ /^dt$/i);

    # treat a DT as a paragraph
    $node->{_tag} = 'p';
    return $self->__Body_P ($node);
}


sub __Body_DD
{
    my $self = shift;
    my $node = shift;

    ref $node || return;
    return unless ($node->{_tag} =~ /^dd$/i);

    my $text = $self->__Content_To_Text ($node);
    $text =~ s/\n/ /gsm;
    $text =~ s/^\s+//;
    $text =~ s/\s+$//;

    my @tokens = split /\s+/, $text;

    local ($Line_Wrap) = $Line_Wrap - length ($DD_Indent);
    my $res = $self->_soft_wrap (@tokens);

    my $indent = $self->_text_indent();
    $res =~ s/\n/\n$indent/g;
    return "\n$indent$res";
}


sub _text_indent
{
    return " " x $DD_Indent;
}


sub _soft_wrap
{
    my $self   = shift;
    my @tokens = @_;

    my @res       = ();
    my @next_line = ();
    while (@tokens)
    {
	my $next_token = shift (@tokens);
	my $potential_line = join " ", (@next_line, $next_token);

	if (length ($potential_line) > $Line_Wrap)
	{
	    if (@next_line == 0)
	    {
		push @res, $next_token;
	    }
	    else
	    {
		unshift (@tokens, $next_token);
		push @res, join " ", @next_line;
		@next_line = ();
	    }
	}
	else
	{
	    push @next_line, $next_token;
	}
    }

    push @res, join " ", @next_line unless (@next_line == 0);
    return join " \n", @res;
}


1;


__END__