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 Encode qw(decode encode);

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

our $VERSION = '0.02';

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

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}          ||= {};
    $mail->{attachments_size_max} ||=  0; #no limit "-1" means no attachment allowed

    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 = $ARG->{subject} || $self->{subject} || '';

    my $flnoc = 67;
    my $nlnoc = 78;
    my $bol   = " =?$charset?Q?";
    my $eol   = "?=\n";

    {
        # this part consider multibytes characters and keep that folding
        # does  not  divide  the  multibyte  characters  into  two lines.
        # The  reason  is  that  some  email clients are not able to put
        # together these separated bytes into one character.
        require bytes;


        my $t_subject = decode( $charset, $subject ) if $charset;

        if ( bytes::length($t_subject) > length($t_subject) || $t_subject =~ /[^\0-\xFF]/ ) {

            $subject = '';
            my $t_string = ''; # substring of $t_subject which is testing if can be added to $subject
            my $t_length =  0; # the length of $t_subject

            my $t_return = ''; # $t_string which match to the condition
            my $t_result = ''; # encoded string of $t_string
            my $t_number =  0; # number of row of the folded "Subject" field
            while ( $t_subject ) {
                foreach(0..$flnoc) {
                    $t_string = substr($t_subject,0,$_);
                    $t_result = encode_qp(encode($charset,$t_string),{bol=>$bol,eol=>$eol,flnoc=>0,nlnoc=>0,charset=>$charset,});

                    #checking if encoded string $t_result of the tested substring $t_string satisfies length condition:
                    # and if yes we go out with the last good value $t_return and $t_subject get shorter by $t_length
                    last if length( $t_result ) > ($t_number ? $nlnoc : $flnoc);
                    $t_return = $t_result;
                    $t_length = length($t_string);
                }
                $subject = $subject.$t_return;
                $t_subject = substr( $t_subject, $t_length );
                $t_number++;
            }

        } else {
            $subject = encode_qp( $subject , { bol=>$bol, eol=>$eol, flnoc=>$flnoc, nlnoc=>$nlnoc, charset=>$charset, } );
        }
    }

    $subject = substr($subject,1);

    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; format=flowed\n"
    ."Content-Transfer-Encoding: 8bit\n\n"
    .$ARG->{'message'}."\n";

#    ."Content-Transfer-Encoding: quoted-printable\n\n"
#    .encode_qp( $ARG->{'message'}, {} )."\n";

    $ARG->{attachments}          ||= $self->{attachments} || {};
    $ARG->{attachments_size_max} ||= $self->{attachments_size_max} || 0; #no limit "-1" means no attachment allowed

    return "Attachments are not allowed whereas some are preperad to send!" if $ARG->{attachments} && $ARG->{attachments_size_max} < 0;
    # attachment files are packed one by one into the message part each divided by boundary

    # checking attachments:
    foreach my $fileName ( sort keys %{$ARG->{'attachments'}} ) {

           my $fileLocation = $ARG->{'attachments'}->{$fileName};

        # if does not exists:
        return "Attachment does not exists! [$fileLocation]" unless -f $fileLocation;

        # if it is too big:
        my $size = -s $fileLocation || 0;
        return "Attachment too big! [$fileLocation: $size > ".$ARG->{attachments_size_max}."B max.]"
            if $ARG->{attachments_size_max} > 0 && $size > $ARG->{attachments_size_max};
    }


    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'  with  the  following changes:
    #   1. The second argument can be scalar - as previously -
    #      or hash which would contain more information
    #   2. There  are changes in counting character in each line in accordance
    #      with hash sent  to the function: it can be  different in first line
    #      and the next ones. It is so, because usually in the firs line there
    #      is some word (Subject for instance).
    # The behaviour of the function is identical with the original one in case
    # we send two scalar arguments only.
    ############################################################################

    # $res = text to be encoded
    my ( $res ) = ( shift );
    return '' unless $res;

    # The arguments can be sent in old way, when the second argument was the
    # end of character rows, or in a new way - as a hash:
    my %par = (
      bol   => " ",  # characters at the begining of each lines
      eol   => "\n", # characters at the end of each line
      flnoc => 68,   # first line number of characters, 0 = unlimit
      nlnoc => 78,   # next lines number of characters, 0 = unlimit
    );

    while ( my $key = shift ) {
        if ( ref ( $key ) eq 'HASH' ) {
            foreach my $k (sort keys %{$key} ) {
                next unless $k =~ /^(bol|charset|eol|flnoc|nlnoc)$/;
                next if $k eq 'flnoc' && $par{$k} !~ /^\d+$/;
                next if $k eq 'nlnoc' && $par{$k} !~ /^\d+$/;

                $par{$k} = $$key{$k};
            }
        } else { # you can only send - as a second scalar argument the "EOL"
                 # characters in accordance with the original function
            $par{eol} = $key;
        }
    }

    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");
        }
    }

    # usefull shorthands
    my $bol   = $par{bol};
    my $eol   = $par{eol};
    my $flnoc = $par{flnoc} - 0 - length($eol) - length($bol);
    my $nlnoc = $par{nlnoc} - 1 - length($eol) - length($bol);
    my $mid   = '';
    unless ( defined $bol ) { $mid = '='; $bol = '' }

    # 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 = "";

    $brokenlines .= "$bol$1$mid$eol" if $flnoc && $res =~ s/(.*?^[^\n]{$flnoc} (?:
         [^=\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;

    $brokenlines .= "$bol$1$mid$eol" while $nlnoc && $res =~ s/(.*?^[^\n]{$nlnoc} (?:
         [^=\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;

    $brokenlines .= "$bol$res$eol" if $res;

#print "$brokenlines\n";
    $brokenlines;
}

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

1;

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

=pod

=head1 NAME

    Mail::Sendmail::Enhanced v.0.02 = L + encoding + attachments (pure Perl)

=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',
    },
    attachments_size_max => 0,
  );

  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

Enhanced version of the module Mail::Sendmail with multibytes encoding
and attachments. It is pure Perl solution.

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.

Simple  encoding  multibytes  character long header field  "Subject:"
caused that  some characters were  divided  between  two folded rows.
Some email clients are not able to put together these separated bytes
into one character  and words were displeyed  inproperly.  Since  the
version 0.02 this problem is solved by keeping bytes of one character
in one folded row.

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.

It possible to do additional specificification of sending attachments
throug the parameter B. The possible values are:

  attachments_size_max =>  0,       # No limit for sizes of attachments

  attachments_size_max => -1,       # Negative value means that sending attachments is forbidden.
                                    # Every try of sending them with this value negative is fatal one.

  attachments_size_max => 100000,   # Positive value is maximum size limit of attachment.
                                    # When attachment is bigger then fatal error is return;


=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 (C) 2015 Waldemar Biernacki, C<<  >>

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