File Coverage

blib/lib/Mail/Sendmail/Enhanced.pm

Criterion	Covered	Total	%
statement	15	15	100.0
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	20	20	100.0

package Mail::Sendmail::Enhanced;

use 5.008;

use strict;
use warnings;

use utf8;
use Mail::Sendmail '0.79_16';
use MIME::Base64;

our $VERSION = '0.01';

################################################################################

sub new
{
	my ( $this ) = ( shift );

	my $mail = {};
	bless ( $mail, $this );

	while ( my $key = shift ) {
		if ( ref ( $key ) eq 'HASH' ) {
			foreach my $k (sort keys %{$key} ) {
				$mail->{$k} = $$key{$k};
			}
		} else {
			my $value = shift;
			$mail->{$key} = $value;
		}
    }

    $mail->{smtp}		||= '';
    $mail->{from}		||= '';
    $mail->{charset}	||= 'utf-8';
    $mail->{type}		||= 'text/plain';

    $mail->{user}		||= '';
    $mail->{pass}		||= '';
    $mail->{method}		||= 'LOGIN';
    $mail->{required}	||= 1;

    $mail->{to}			||= '';
    $mail->{cc}			||= '';
    $mail->{subject}	||= 'No subject defined';
    $mail->{message}	||= 'No message defined!';

    $mail->{attachments}||= {};

    return $mail;
}

################################################################################

sub send
{
	my ( $self, $ARG ) = ( shift, shift );

	$ARG->{to} || $ARG->{cc} || die 'No to: or cc: email address given!';

	my $charset  = $ARG->{'charset'} || $self-> {charset} || 'utf-8';
	my $type     = $ARG->{'type'}    || $self-> {type}    || 'text/plain';

	my $boundary = "====" . time() . "====";

	# Email subject is encoded using proper character encoding.
	# original "encode_qp" function contains up to 2 arguments,
	# but in a case of character set it is needed to start every
	# new line with a statemant of the encoding, so - as a the
	# third parameter - the charset is sent to the function.

	my $subject = $self->encode_qp( $ARG->{subject} || $self->{subject} || '' , "?=\n", "=?$charset?Q?" );

    my %mail = (
	'X-Mailer'		=> "This is Perl Mail::Sendmail::Enhanced version $Mail::Sendmail::Enhanced::VERSION",
	'Content-Type'	=> "multipart/mixed; charset=$charset; boundary=\"$boundary\"",
	'Smtp'			=> ($ARG->{smpt}|| $self->{smtp}     ),
	'From'			=> ($ARG->{from}|| $self->{from}     ),
	'To'			=> ($ARG->{to}	|| $self->{to} || '' ),
	'Cc'			=> ($ARG->{cc}	|| $self->{cc} || '' ),
	'Subject'		=>  $subject,
	auth			=> {
						user	=> ($ARG->{user}	|| $self->{user}     ),
						pass	=> ($ARG->{pass}	|| $self->{pass}     ),
						method	=> ($ARG->{method}	|| $self->{method}   ),
						required=> ($ARG->{required}|| $self->{required} ),
					   },
    );

	$boundary = '--'.$boundary;
	$mail{'Message'} = "$boundary\n"
	."Content-Type: $type; charset=$charset\n"
	."Content-Transfer-Encoding: quoted-printable\n\n"
	.$self->encode_qp( $ARG->{'message'} , '', '' )."\n";

	$ARG->{'attachments'} ||= $self-> {attachments};

	# attachment files are packed one by one into the message part each divided by boundary

    foreach my $fileName ( sort keys %{$ARG->{'attachments'}} ) {
		my $fileLocation = $ARG->{'attachments'}->{$fileName};
		if (open (my $F, $fileLocation )) {
			my $input_record_separator = $/;
			binmode $F; undef $/;
			my $attachment = encode_base64(<$F>);
			close $F;
			$/ = $input_record_separator;

			$mail{'Message'} .= "$boundary\n"
			."Content-Type: application/octet-stream; name=\"$fileName\"\n"
			."Content-ID: <$fileName>\n"
			."Content-Transfer-Encoding: base64\n"
			."Content-Disposition: attachment; filename=\"$fileName\"\n\n"
			."$attachment\n";
		}
	}

	$mail{'Message'} .= "$boundary--\n";

	return $Mail::Sendmail::error unless sendmail( %mail );

	return;
}

################################################################################

sub encode_qp
{
	##########################################################################
	# This function is an exact copy of the that of the same name
	# from the module: MIME::QuotedPrint::Perl '1.00'" however with
	# the following changes:
	#   1. number of arguments increases to 3 insted of 2 previously.
	#   2. The third argument represents the begining of each encoded lines
	#       which contains character set (requirement by mail subject field.
	#   3. There are some changes in counting character in each line.
	#      Because of requirements of the specification the first line -
	#      because of the key word "Subject:" line may contain only 65 not
	#      73 characters.
	# The behaviour of the function is identical with the original one
	# in case we send two arguments only (the third is undefined)
	##########################################################################

    my ( $self, $res, $eol, $bol ) = ( shift, shift, shift, shift );

	# $self= mail object
	# $res = encoded text
	# $eol = characters at the end of each encoded line
	# $bol = characters at the begining of each encoded line


    if ($] >= 5.006) {
		require bytes;
		if (bytes::length($res) > length($res) || ($] >= 5.008 && $res =~ /[^\0-\xFF]/))
		{
			require Carp;
			Carp::croak("The Quoted-Printable encoding is only defined for bytes");
		}
    }

    $eol = "\n" unless defined $eol;
    my $mid = '';
    unless ( defined $bol ) { $mid = '='; $bol = '' }

	my $RE_Z = "\\z";
	$RE_Z = "\$" if $] < 5.005;

    # Do not mention ranges such as $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg;
    # since that will not even compile on an EBCDIC machine (where ord('!') > ord('<')).
    if (ord('A') == 193) { # EBCDIC style machine
        if (ord('[') == 173) {
            $res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp1047',$1))))/eg;  # rule #2,#3
            $res =~ s/([ \t]+)$/
              join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp1047',$_)))) }
        		   split('', $1)
              )/egm;                        # rule #3 (encode whitespace at eol)
        }
        elsif (ord('[') == 187) {
            $res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('posix-bc',$1))))/eg;  # rule #2,#3
            $res =~ s/([ \t]+)$/
              join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('posix-bc',$_)))) }
        		   split('', $1)
              )/egm;                        # rule #3 (encode whitespace at eol)
        }
        elsif (ord('[') == 186) {
            $res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp37',$1))))/eg;  # rule #2,#3
            $res =~ s/([ \t]+)$/
              join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp37',$_)))) }
        		   split('', $1)
              )/egm;                        # rule #3 (encode whitespace at eol)
        }
    }
    else { # ASCII style machine
        $res =~  s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord($1))/eg;  # rule #2,#3
	$res =~ s/\n/=0A/g unless length($eol);
        $res =~ s/([ \t]+)$/
          join('', map { sprintf("=%02X", ord($_)) }
    		   split('', $1)
          )/egm;                        # rule #3 (encode whitespace at eol)
    }

    return $res unless length($eol);

    # rule #5 (lines must be shorter than 76 chars, but we are not allowed
    # to break =XX escapes.  This makes things complicated :-( )
    my $brokenlines = "";
    my $noc = 65; #number of characters in the first final line (becouse of the letters "Subject:"
    $brokenlines .= " $bol$1$mid$eol"
	while $res =~ s/(.*?^[^\n]{$noc} (?:
		 [^=\n]{2} (?! [^=\n]{0,1} $) # 75 not followed by .?\n
		|[^=\n]    (?! [^=\n]{0,2} $) # 74 not followed by .?.?\n
		|          (?! [^=\n]{0,3} $) # 73 not followed by .?.?.?\n
	    ))//xsm;
    $res =~ s/\n$RE_Z/$eol/o;

    $brokenlines .= " $bol$res$eol" if $res;
    $brokenlines =~ s/^ //;
    $brokenlines;
}

################################################################################

1;

################################################################################

=pod

=head1 NAME

Mail::Sendmail::Enhanced - This is enhanced version of the L
module with encoding and attachments added.

=head1 SYNOPSIS

  #!/usr/bin/perl -w

  use strict;
  use warnings;

  use Mail::Sendmail::Enhanced;

  my $MAIL = Mail::Sendmail::Enhanced-> new(
    charset     => 'UTF-8',
    smtp        => 'Your SMTP server',
    from        => 'Your mail',
    user        => 'user',
    pass        => 'password',
    method      => 'LOGIN',
    required    => 1,
    attachments => {
      'name for email of the file1' => 'OS file1 location',
      'name for email of the file2' => 'OS file2 location',
    },
  );

  for (1..2) {
    print $MAIL-> send( {
      to    => 'author of the module: ',
      subject  => "Subject longer than 80 characters with Polish letters: lowercase: ąćęłńóśźż and uppercase: ĄĆĘŁŃÓŚŹŻ.",
      message  => "This is the message nr $_. in the character encoding UTF-8.

      This is an example of using UTF-8 Polish letters in an email subject field: encoded and longer than 80 characters.",

  __END__

=head1 DESCRIPTION

This module is enhanced version of the module L.
It preserved the nicest feature of the original modules:
the pure Perl solution method.

From L:

"Simple  platform  independent  e-mail  from  your  perl script. Only
requires Perl 5 and a network connection. Mail::Sendmail takes a hash
with  the  message  to  send  and sends it to your mail server. It is
intended to be very easy to setup and use."

In L two things were added:

1. Encoding - which uses the refurbish function B from the
module L which  is put into  the current one.
This is pure Perl solution.

2. Attachments - which allows to add attachments easily.  It makes it
by using the technique connected with "multipart/mixed" and "boundary"
'Content-Type' attribute.

List of files to send (attachments) is given as a simple hash:

  attachments => {
    'name for email of the file1' => 'OS file1 location',
    'name for email of the file2' => 'OS file2 location',
  },

where the keys of the hash are "public" (in email) names of files and
values of the hash are these files OS locations, respectively.

=head1 AUTHOR

Waldemar Biernacki, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to
C, or through the web interface at
L.
I will be notified, and then you'll automatically be notified of progress on your
bug as I make changes.

=head1 LICENSE AND COPYRIGHT

Copyright 2015 Waldemar Biernacki.

This program is free software; you can redistribute it and/or modify it
under the terms of the the Artistic License (2.0). You may obtain a
copy of the full license at:

L

Any use, modification, and distribution of the Standard or Modified
Versions is governed by this Artistic License. By using, modifying or
distributing the Package, you accept this license. Do not use, modify,
or distribute the Package, if you do not accept this license.

If your Modified Version has been derived from a Modified Version made
by someone other than you, you are nevertheless required to ensure that
your Modified Version complies with the requirements of this license.

This license does not grant you the right to use any trademark, service
mark, tradename, or logo of the Copyright Holder.

This license includes the non-exclusive, worldwide, free-of-charge
patent license to make, have made, use, offer to sell, sell, import and
otherwise transfer the Package with respect to any patent claims
licensable by the Copyright Holder that are necessarily infringed by the
Package. If you institute patent litigation (including a cross-claim or
counterclaim) against any party alleging that the Package constitutes
direct or contributory patent infringement, then this Artistic License
to you shall terminate on the date that such litigation is filed.

Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

=head1 SEE ALSO

L, L

=cut