| Current Path : /usr/share/perl5/vendor_perl/Mail/ |
Linux gator3171.hostgator.com 4.19.286-203.ELK.el7.x86_64 #1 SMP Wed Jun 14 04:33:55 CDT 2023 x86_64 |
| Current File : //usr/share/perl5/vendor_perl/Mail/Sender.pm |
# Mail::Sender.pm version 0.8.23
#
# Copyright (c) 2001 Jan Krynicky <Jenda@Krynicky.cz>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Mail::Sender; local $^W;
require 'Exporter.pm';
use vars qw(@ISA @EXPORT @EXPORT_OK);
@ISA = (Exporter);
@EXPORT = qw();
@EXPORT_OK = qw(@error_str GuessCType);
$Mail::Sender::VERSION = '0.8.23';
$Mail::Sender::ver=$Mail::Sender::VERSION;
use 5.008;
use strict;
use warnings;
no warnings 'uninitialized';
use Carp;
use FileHandle;
use IO::Socket::INET;
use File::Basename;
use Encode qw(encode decode);
use MIME::Base64;
use MIME::QuotedPrint;
# if you do not use MailFile or SendFile and only send 7BIT or 8BIT "encoded"
# messages you may comment out these lines.
#MIME::Base64 and MIME::QuotedPrint may be found at CPAN.
my $TLS_notsupported;
BEGIN {
eval <<'*END*'
use IO::Socket::SSL;# qw(debug4);
use Net::SSLeay;
1;
*END*
or $TLS_notsupported = $@;
}
# include config file and libraries when packaging the script
if (0) {
require 'Mail/Sender.config'; # local configuration
require 'Symbol.pm'; # for debuging and GetHandle() method
require 'Tie/Handle.pm'; # for debuging and GetHandle() method
require 'IO/Handle.pm'; # for debuging and GetHandle() method
require 'Digest/HMAC_MD5.pm'; # for CRAM-MD5 authentication only
require 'Authen/NTLM.pm'; # for NTLM authentication only
} # this block above is there to let PAR, PerlApp, PerlCtrl, PerlSvc and Perl2Exe know I may need those files.
BEGIN {
my $config = $INC{'Mail/Sender.pm'};
die "Wrong case in use statement or Mail::Sender module renamed. Perl is case sensitive!!!\n" unless $config;
my $compiled = !(-e $config); # if the module was not read from disk => the script has been "compiled"
$config =~ s/\.pm$/.config/;
if ($compiled or -e $config) {
# in a Perl2Exe or PerlApp created executable or PerlCtrl generated COM object
# or the config is known to exist
eval {require $config};
if ($@ and $@ !~ /Can't locate /) {
print STDERR "Error in Mail::Sender.config : $@" ;
}
}
}
#local IP address and name
my $local_name = $ENV{HOSTNAME} || $ENV{HTTP_HOST} || (gethostbyname 'localhost')[0];
$local_name =~ s/:.*$//; # the HTTP_HOST may be set to something like "foo.bar.com:1000"
my $local_IP = join('.',unpack('CCCC',(gethostbyname $local_name)[4]));
#time diference to GMT - Windows will not set $ENV{'TZ'}, if you know a better way ...
my $GMTdiff;
use Time::Local;
sub ResetGMTdiff {
my $local = time;
my $gm = timelocal( gmtime $local );
my $sign = qw( + + - )[ $local <=> $gm ];
$GMTdiff = sprintf "%s%02d%02d", $sign, (gmtime abs( $local - $gm ))[2,1];
}
ResetGMTdiff();
#
my @priority = ('','1 (Highest)','2 (High)', '3 (Normal)','4 (Low)','5 (Lowest)');
#data encoding
my $chunksize=1024*4;
my $chunksize64=71*57; # must be divisible by 57 !
sub enc_base64 {
if ($_[0]) {
my $charset = $_[0];
sub {my $s = encode_base64(encode( $charset, $_[0])); $s =~ s/\x0A/\x0D\x0A/sg; return $s;}
} else {
sub {my $s = encode_base64($_[0]); $s =~ s/\x0A/\x0D\x0A/sg; return $s;}
}
}
my $enc_base64_chunk = 57;
sub enc_qp {
if ($_[0]) {
my $charset = $_[0];
sub {my $s = encode( $charset, $_[0]);$s =~ s/\x0D\x0A/\n/g;$s = encode_qp($s); $s=~s/^\./../gm; $s =~ s/\x0A/\x0D\x0A/sg; return $s}
} else {
sub {my $s = $_[0];$s =~ s/\x0D\x0A/\n/g;$s = encode_qp($s); $s=~s/^\./../gm; $s =~ s/\x0A/\x0D\x0A/sg; return $s}
}
}
sub enc_plain {
if ($_[0]) {
my $charset = $_[0];
sub {my $s = encode( $charset, $_[0]); $s=~s/^\./../gm; $s =~ s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg; return $s}
} else {
sub {my $s = $_[0]; $s=~s/^\./../gm; $s =~ s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg; return $s}
}
}
sub enc_xtext {
my $input = shift;
$input =~ s/([^!-*,-<>-~])/'+'.uc(unpack('H*', $1))/eg;
return $input;
}
{ my $username;
sub getusername () {
return $username if defined($username);
return $username=eval{getlogin || getpwuid($<)} || $ENV{USERNAME};
}
}
#IO
use vars qw($debug);
$debug = 0;
#reads the whole SMTP response
# converts
# nnn-very
# nnn-long
# nnn message
# to
# nnn very
# long
# message
sub get_response ($) {
my $s = shift;
my $res = <$s>;
if ($res =~ s/^(\d\d\d)-/$1 /) {
my $nextline = <$s>;
while ($nextline =~ s/^\d\d\d-//) {
$res .= $nextline;
$nextline = <$s>;
}
$nextline =~ s/^\d\d\d //;
$res .= $nextline;
}
$Mail::Sender::LastResponse = $res;
return $res;
}
sub send_cmd ($$) {
my ($s, $cmd) = @_;
chomp $cmd;
if ($s->opened()) {
print $s "$cmd\x0D\x0A";
get_response($s);
} else {
return '400 connection lost';
}
}
sub print_hdr {
my ($s, $hdr, $str, $charset) = @_;
return if !defined $str or $str eq '';
$str =~ s/[\x0D\x0A\s]+$//;
if ($charset && $str =~ /[^[:ascii:]]/) {
$str = encode( $charset, $str);
my @parts = split /(\s*[,;<> ]\s*)/, $str;
$str = '';
for (my $i = 0; $i < @parts; $i++) {
my $part = $parts[$i];
$part .= $parts[++$i] if ($i < $#parts && $parts[$i+1] =~ /^\s+$/);
if ($part =~ /[^[:ascii:]]/ || $part =~ /[\r\n\t]/) {
$part = encode_qp($part, '');
$part =~ s/([\s\?])/'=' . sprintf '%02x',ord($1)/ge;
$str .= "=?$charset?Q?$part?=";
} else {
$str .= $part;
}
}
}
$str =~ s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg; # \n or \r => \r\n
$str =~ s/\x0D\x0A([^\t])/\x0D\x0A\t$1/sg;
if (length($str)+length($hdr) > 997) { # header too long, max 1000 chars
$str =~ s/(.{1,980}[;,])\s+(\S)/$1\x0D\x0A\t$2/g;
}
print $s "$hdr: $str\x0D\x0A";
}
sub say_helo {
my ($self, $s) = @_;
my $res = send_cmd $s, "EHLO $self->{'client'}";
if ($res !~ /^[123]/) {
$res = send_cmd $s, "HELO $self->{'client'}";
if ($res !~ /^[123]/) { return $self->Error(COMMERROR($_));}
return;
}
$res =~ s/^.*\n//;
$self->{'supports'} = {map {split /(?:\s+|=)/, $_, 2} split /\n/, $res};
if (exists $self->{'supports'}{AUTH}) {
my @auth = split /\s+/, uc($self->{'supports'}{AUTH});
$self->{'auth_protocols'} = {map {$_, 1} @auth};
# create a hash with accepted authentication protocols
}
$self->{esmtp}{_MAIL_FROM} = '';
$self->{esmtp}{_RCPT_TO} = '';
if (exists $self->{'supports'}{DSN} and exists $self->{esmtp}) {
for (qw(RET ENVID)) {
$self->{esmtp}{_MAIL_FROM} .= " $_=$self->{esmtp}{$_}"
if $self->{esmtp}{$_} ne '';
}
for (qw(NOTIFY ORCPT)) {
$self->{esmtp}{_RCPT_TO} .= " $_=$self->{esmtp}{$_}"
if $self->{esmtp}{$_} ne '';
}
}
return;
}
sub login {
my $self = shift();
my $auth = uc( $self->{'auth'}) || 'LOGIN';
if (! $self->{'auth_protocols'}->{$auth}) {
return $self->Error(INVALIDAUTH($auth));
}
$self->{'authid'} = $self->{'username'}
if (exists $self->{'username'} and !exists $self->{'authid'});
$self->{'authpwd'} = $self->{'password'}
if (exists $self->{'password'} and !exists $self->{'authpwd'});
$auth =~ tr/a-zA-Z0-9_/_/c; # change all characters except letters, numbers and underscores to underscores
no strict qw'subs refs';
&{"Mail::Sender::Auth::".$auth}($self);
}
# authentication code stolen from http://support.zeitform.de/techinfo/e-mail_prot.html
sub Mail::Sender::Auth::LOGIN {
my $self = shift();
my $s = $self->{'socket'};
$_ = send_cmd $s, 'AUTH LOGIN';
if (!/^[123]/) { return $self->Error(INVALIDAUTH('LOGIN', $_)); }
if ($self->{auth_encoded}) {
# I assume the username and password had been base64 encoded already!
$_ = send_cmd $s, $self->{'authid'};
if (!/^[123]/) { return $self->Error(LOGINERROR($_)); }
$_ = send_cmd $s, $self->{'authpwd'};
if (!/^[123]/) { return $self->Error(LOGINERROR($_)); }
} else {
$_ = send_cmd $s, &encode_base64($self->{'authid'}, '');
if (!/^[123]/) { return $self->Error(LOGINERROR($_)); }
$_ = send_cmd $s, &encode_base64($self->{'authpwd'}, '');
if (!/^[123]/) { return $self->Error(LOGINERROR($_)); }
}
return;
}
use vars qw($MD5_loaded);
$MD5_loaded = 0;
sub Mail::Sender::Auth::CRAM_MD5 {
my $self = shift();
my $s = $self->{'socket'};
$_ = send_cmd $s, "AUTH CRAM-MD5";
if (!/^[123]/) { return $self->Error(INVALIDAUTH('CRAM-MD5', $_)); }
my $stamp = $1 if /^\d{3}\s+(.*)$/;
unless ($MD5_loaded) {
eval 'use Digest::HMAC_MD5 qw(hmac_md5_hex)';
die "$@\n" if $@;
$MD5_loaded = 1;
}
my $user = $self->{'authid'};
my $secret = $self->{'authpwd'};
my $decoded_stamp = decode_base64($stamp);
my $hmac = hmac_md5_hex($decoded_stamp, $secret);
my $answer = encode_base64($user . ' ' . $hmac, '');
$_ = send_cmd $s, $answer;
if (!/^[123]/) { return $self->Error(LOGINERROR($_)); }
return;
}
sub Mail::Sender::Auth::PLAIN {
my $self = shift();
my $s = $self->{'socket'};
$_ = send_cmd $s, "AUTH PLAIN";
if (!/^[123]/) { return $self->Error(INVALIDAUTH('PLAIN', $_)); }
$_ = send_cmd $s, encode_base64("\000" . $self->{'authid'} . "\000" . $self->{'authpwd'}, '');
if (!/^[123]/) { return $self->Error(LOGINERROR($_)); }
return;
}
{
my $NTLM_loaded=0;
sub Mail::Sender::Auth::NTLM {
unless ($NTLM_loaded) {
eval "use Authen::NTLM qw();";
die "$@\n" if $@;
$NTLM_loaded = 1;
}
my $self = shift();
my $s = $self->{'socket'};
$_ = send_cmd $s, "AUTH NTLM";
if (!/^[123]/) { return $self->Error(INVALIDAUTH('NTLM', $_)); }
Authen::NTLM::ntlm_reset();
Authen::NTLM::ntlm_user($self->{'authid'});
Authen::NTLM::ntlm_password($self->{'authpwd'});
Authen::NTLM::ntlm_domain($self->{'authdomain'})
if defined $self->{'authdomain'};
$_ = send_cmd $s, Authen::NTLM::ntlm();
if (!/^3\d\d (.*)$/s) { return $self->Error(LOGINERROR($_)); }
my $response = $1;
$_ = send_cmd $s, Authen::NTLM::ntlm($response);
if (!/^[123]/) { return $self->Error(LOGINERROR($_)); }
return;
}}
sub Mail::Sender::Auth::AUTOLOAD {
(my $auth = $Mail::Sender::Auth::AUTOLOAD) =~ s/.*:://;
my $self = shift();
my $s = $self->{'socket'};
send_cmd $s, "QUIT";
close $s;
delete $self->{'socket'};
return $self->Error( UNKNOWNAUTH($auth));
}
my $debug_code;
sub __Debug {
my ($socket, $file) = @_;
if (defined $file) {
unless (@Mail::Sender::DBIO::ISA) {
eval "use Symbol;";
eval $debug_code;
die $@ if $@;
}
my $handle = gensym();
*$handle = \$socket;
if (! ref $file) {
my $DEBUG = new FileHandle;
open $DEBUG, "> $file" or die "Cannot open the debug file '$file': $^E\n";
binmode $DEBUG;
$DEBUG->autoflush();
tie *$handle, 'Mail::Sender::DBIO', $socket, $DEBUG, 1;
} else {
my $DEBUG = $file;
tie *$handle, 'Mail::Sender::DBIO', $socket, $DEBUG, 0;
}
bless $handle, 'Mail::Sender::DBIO';
return $handle;
} else {
return $socket;
}
}
#internale
sub HOSTNOTFOUND {
$!=2;
$Mail::Sender::Error="The SMTP server $_[0] was not found";
return -1, $Mail::Sender::Error;
}
sub SOCKFAILED {
$Mail::Sender::Error='socket() failed: $^E';
$!=5;
return -2, $Mail::Sender::Error;
}
sub CONNFAILED {
$Mail::Sender::Error="connect() failed: $^E";
$!=5;
return -3, $Mail::Sender::Error;
}
sub SERVNOTAVAIL {
$!=40;
$Mail::Sender::Error="Service not available. " . ($_[0] ? "Reply: $_[0]" : "Server closed the connection unexpectedly");
return -4, $Mail::Sender::Error;
}
sub COMMERROR {
$!=5;
if ($_[0] eq '') {
$Mail::Sender::Error="No response from server";
} else {
$Mail::Sender::Error="Server error: $_[0]";
}
return -5, $Mail::Sender::Error;
}
sub USERUNKNOWN {
$!=2;
if ($_[2] and $_[2] !~ /Local user/i) {
my $err= $_[2];
$err =~ s/^\d+\s*//;
$err =~ s/\s*$//s;
$err ||= "Error";
$Mail::Sender::Error="$err for \"$_[0]\" on host \"$_[1]\"";
} else {
$Mail::Sender::Error="Local user \"$_[0]\" unknown on host \"$_[1]\"";
}
return -6, $Mail::Sender::Error;
}
sub TRANSFAILED {
$!=5;
$Mail::Sender::Error="Transmission of message failed ($_[0])";
return -7, $Mail::Sender::Error;
}
sub TOEMPTY {
$!=14;
$Mail::Sender::Error="Argument \$to empty";
return -8, $Mail::Sender::Error;
}
sub NOMSG {
$!=22;
$Mail::Sender::Error="No message specified";
return -9, $Mail::Sender::Error;
}
sub NOFILE {
$!=22;
$Mail::Sender::Error="No file name specified";
return -10, $Mail::Sender::Error;
}
sub FILENOTFOUND {
$!=2;
$Mail::Sender::Error="File \"$_[0]\" not found";
return -11, $Mail::Sender::Error;
}
sub NOTMULTIPART {
$!=40;
$Mail::Sender::Error="$_[0] not available in singlepart mode";
return -12, $Mail::Sender::Error;
}
sub SITEERROR {
$!=15;
$Mail::Sender::Error="Site specific error";
return -13, $Mail::Sender::Error;
}
sub NOTCONNECTED {
$!=1;
$Mail::Sender::Error="Connection not established";
return -14, $Mail::Sender::Error;
}
sub NOSERVER {
$!=22;
$Mail::Sender::Error="No SMTP server specified";
return -15, $Mail::Sender::Error;
}
sub NOFROMSPECIFIED {
$!=22;
$Mail::Sender::Error="No From: address specified";
return -16, $Mail::Sender::Error;
}
sub INVALIDAUTH {
$!=22;
$Mail::Sender::Error="Authentication protocol $_[0] is not accepted by the server";
$Mail::Sender::Error.=",\nresponse: $_[1]" if defined $_[1];
return -17, $Mail::Sender::Error;
}
sub LOGINERROR {
$!=22;
$Mail::Sender::Error="Login not accepted";
return -18, $Mail::Sender::Error;
}
sub UNKNOWNAUTH {
$!=22;
$Mail::Sender::Error="Authentication protocol $_[0] is not implemented by Mail::Sender";
return -19, $Mail::Sender::Error;
}
sub ALLRECIPIENTSBAD {
$!=2;
return -20, $Mail::Sender::Error;
}
sub FILECANTREAD {
$Mail::Sender::Error="File \"$_[0]\" cannot be read: $^E";
return -21, $Mail::Sender::Error;
}
sub DEBUGFILE {
$Mail::Sender::Error=$_[0];
return -22, $Mail::Sender::Error;
}
sub STARTTLS {
$Mail::Sender::Error="STARTTLS failed: $_[0] $_[1]";
$!=5;
return -23, $Mail::Sender::Error;
}
sub IO_SOCKET_SSL {
$Mail::Sender::Error="IO::Socket::SSL->start_SSL failed: $_[0]";
$!=5;
return -24, $Mail::Sender::Error;
}
sub TLS_UNSUPPORTED_BY_ME {
$Mail::Sender::Error="TLS unsupported by the script: $_[0]";
$!=5;
return -25, $Mail::Sender::Error;
}
sub TLS_UNSUPPORTED_BY_SERVER {
$Mail::Sender::Error="TLS unsupported by server";
$!=5;
return -26, $Mail::Sender::Error;
}
sub UNKNOWNENCODING {
$Mail::Sender::Error="Unknown encoding '$_[0]'";
$!=5;
return -27, $Mail::Sender::Error;
}
@Mail::Sender::Errors = (
'OK',
'Unknown encoding',
'TLS unsupported by server',
'TLS unsupported by script',
'IO::SOCKET::SSL failed',
'STARTTLS failed',
'debug file cannot be opened',
'file cannot be read',
'all recipients have been rejected',
'authentication protocol is not implemented',
'login not accepted',
'authentication protocol not accepted by the server',
'no From: address specified',
'no SMTP server specified',
'connection not established. Did you mean MailFile instead of SendFile?',
'site specific error',
'not available in singlepart mode',
'file not found',
'no file name specified in call to MailFile or SendFile',
'no message specified in call to MailMsg or MailFile',
'argument $to empty',
'transmission of message failed',
'local user $to unknown on host $smtp',
'unspecified communication error',
'service not available',
'connect() failed',
'socket() failed',
'$smtphost unknown'
);
=head1 NAME
Mail::Sender - module for sending mails with attachments through an SMTP server
Version 0.8.23
=head1 SYNOPSIS
use Mail::Sender;
$sender = new Mail::Sender
{smtp => 'mail.yourdomain.com', from => 'your@address.com'};
$sender->MailFile({to => 'some@address.com',
subject => 'Here is the file',
msg => "I'm sending you the list you wanted.",
file => 'filename.txt'});
=head1 DESCRIPTION
C<Mail::Sender> provides an object oriented interface to sending mails.
It doesn't need any outer program. It connects to a mail server
directly from Perl, using Socket.
Sends mails directly from Perl through a socket connection.
=head1 new Mail::Sender
new Mail::Sender ([from [,replyto [,to [,smtp [,subject [,headers [,boundary]]]]]]])
new Mail::Sender {[from => 'somebody@somewhere.com'] , [to => 'else@nowhere.com'] [, ...]}
Prepares a sender. This doesn't start any connection to the server. You
have to use C<$Sender->Open> or C<$Sender->OpenMultipart> to start
talking to the server.
The parameters are used in subsequent calls to C<$Sender->Open> and
C<$Sender->OpenMultipart>. Each such call changes the saved variables.
You can set C<smtp>, C<from> and other options here and then use the info
in all messages.
P.S.: The two snippets of code both contain square brackets. They mean a different thing though. In the first case
they denote the optional parameters (square brackets had been used to mean this in various docs for a long time),
in the second case they denote actual anonymous array reference literals ... except for the last pair.
In general the squares that mean "this part is optional" will have a comma as the first character in their content,
the literal ones will not.
=head2 Parameters
=over 4
=item from
C<>=> the sender's e-mail address
=item fake_from
C<>=> the address that will be shown in headers.
If not specified we use the value of C<from>.
=item replyto
C<>=> the reply-to address
=item to
C<>=> the recipient's address(es)
This parameter may be either a comma separated list of email addresses
or a reference to a list of addresses.
=item fake_to
C<>=> the recipient's address that will be shown in headers.
If not specified we use the value of "to".
If the list of addresses you want to send your message to is long or if you do not want
the recipients to see each other's address set the C<fake_to> parameter to some informative,
yet bogus, address or to the address of your mailing/distribution list.
=item cc
C<>=> address(es) to send a copy (CC:) to
=item fake_cc
C<>=> the address that will be shown in headers.
If not specified we use the value of "cc".
=item bcc
C<>=> address(es) to send a copy (BCC: or blind carbon copy).
these addresses will not be visible in the mail!
=item smtp
C<>=> the IP or domain address of your SMTP (mail) server
This is the name of your LOCAL mail server, do NOT try
to contact directly the adressee's mailserver! That would be slow and buggy,
your script should only pass the messages to the nearest mail server and leave
the rest to it. Keep in mind that the recipient's server may be down temporarily.
=item port
C<>=> the TCP/IP port used form the connection. By default getservbyname('smtp', 'tcp')||25.
You should only need to use this option if your mail server waits on a nonstandard port.
=item subject
C<>=> the subject of the message
=item headers
C<>=> the additional headers
You may use this parameter to add custom headers into the message. The parameter may
be either a string containing the headers in the right format or a hash containing the headers
and their values.
=item boundary
C<>=> the message boundary
You usually do not have to change this, it might only come in handy if you need
to attach a multipart mail created by Mail::Sender to your message as a single part.
Even in that case any problems are unlikely.
=item multipart
C<>=> the MIME subtype for the whole message (Mixed/Related/Alternative)
You may need to change this setting if you want to send a HTML body with some
inline images, or if you want to post the message in plain text as well as
HTML (alternative). See the examples at the end of the docs.
You may also use the nickname "subtype".
=item ctype
C<>=> the content type of a single part message or the body of the multipart one.
Please do not confuse these two. The 'multipart' parameter is used to specify
the overall content type of a multipart message (for example a HTML document
with inlined images) while ctype is an ordinary content type for a single
part message or the body of a multipart message.
=item encoding
C<>=> encoding of a single part message or the body of a multipart message.
If the text of the message contains some extended characters or
very long lines you should use 'encoding => "Quoted-printable"' in the
call to Open(), OpenMultipart(), MailMsg() or MailFile().
Keep in mind that if you use some encoding you should either use SendEnc()
or encode the data yourself !
=item charset
C<>=> the charset of the single part message or the body of the multipart one
=item client
C<>=> the name of the client computer.
During the connection you send
the mailserver your computer's name. By default Mail::Sender sends
C<(gethostbyname 'localhost')[0]>.
If that is not the address you need, you can specify a different one.
=item priority
C<>=> the message priority number
1 = highest, 2 = high, 3 = normal, 4 = low, 5 = lowest
=item confirm
C<>=> whether you request reading or delivery confirmations and to what addresses:
"delivery" - only delivery, to the C<from> address
"reading" - only reading, to the C<from> address
"delivery, reading" - both confirmations, to the C<from> address
"delivery: my.other@address.com" - only delivery, to my.other@address.com
...
Keep in mind though that neither of those is guaranteed to work. Some servers/mail clients do not support
this feature and some users/admins may have disabled it. So it's possible that your mail was delivered and read,
but you won't get any confirmation!
=item ESMPT
ESMTP => {
NOTIFY => 'SUCCESS,FAILURE,DELAY',
RET => 'HDRS',
ORCPT => 'rfc822;my.other@address.com',
ENVID => 'iuhsdfobwoe8t237',
}
This option contains data for SMTP extensions, for example it allows you to request delivery
status notifications according to RFC1891.
NOTIFY - to specify the conditions under which a delivery status notification should be generated.
Should be either "NEVER" or a comma separated list of "SUCCESS", "FAILURE" and "DELAY".
ORCPT - used to convey the "original" (sender-specified) recipient address
RET - to request that Delivery Status Notifications containing an indication of delivery
failure either return the entire contents of a message or only the message headers. Must be either
FULL or HDRS
ENVID - used to propagate an identifier for this message transmission envelope, which is also
known to the sender and will, if present, be returned in any Delivery Status Notifications issued
for this transmission
You do not need to worry about encoding the ORCPT or ENVID parameters.
If the SMTP server you connect to doesn't support this extension, the options will be ignored.
=item debug
C<>=> C<"/path/to/debug/file.txt">
or
C<>=> \*FILEHANDLE
or
C<>=> $FH
All the conversation with the server will be logged to that file or handle.
All lines in the file should end with CRLF (the Windows and Internet format).
If even a single one of them does not, please let me know!
If you pass the path to the log file, Mail::Sender will overwrite it. If you want to append to the file,
you have to open it yourself and pass the filehandle:
open my $DEBUG, ">> /path/to/debug/file.txt"
or die "Can't open the debug file: $!\n"
$sender = new Mail::Sender ({
...
debug => $DEBUG,
});
=item debug_level
Only taken into account if the C<debug> option is specified.
1 - only log the conversation with the server, skip all message data
2 - log the conversation and message headers
3 - log the conversation and the message and part headers
4 - log everything (default)
=item auth
the SMTP authentication protocol to use to login to the server
currently the only ones supported are LOGIN, PLAIN, CRAM-MD5 and NTLM.
Some protocols have module dependencies. CRAM-MD5 depends on
Digest::HMAC_MD5 and NTLM on Authen::NTLM.
You may add support for other authentication protocols yourself. See below.
=item authid
the username used to login to the server
=item authpwd
the password used to login to the server
=item authdomain
the domain name. Used optionaly by the NTLM authentication.
Other authentication protocols may use other options as well.
They should all start with "auth" though.
Please see the authentication section bellow.
=item auth_encoded
If set to a true value the LOGIN authentication assumes the authid and authpwd
is already base64 encoded.
=item tls_allowed
If set to a true value Mail::Sender attempts to use LTS (SSL encrypted connection) whenever
the server supports it and you have IO::Socket::SSL and Net::SSLeay.
The default value of this option is TRUE! This means that if Mail::Server can send the data encrypted, it will.
=item tls_required
If you set this option to a true value, the module will fail whenever it's unable to use TLS.
=item ssl_...
The ssl_version, ssl_verify_mode, ssl_ca_path, ssl_ca_file, ssl_verifycb_name, ssl_verifycn_schema and ssl_hostname
options (if specified) are passed to IO::Socket::SSL->start_SSL(). The default for the first two is 'TLSv1' and IO::Socket::SSL::SSL_VERIFY_NONE().
If you change the ssl_verify_mode to SSL_VERIFY_PEER, you may need to specify also the ssl_ca_file. If you have Mozilla::CA installed, then setting it to
Mozilla::CA::SSL_ca_file() may help.
=item keepconnection
If set to a true value causes the Mail::Sender to keep the connection open for several messages.
The connection will be closed if you call the Close() method with a true value or if you call Open,
OpenMultipart, MailMsg or MailFile with the "smtp" parameter.
This means that if you want the object to keep the connection you should pass the "smtp" either to "new Mail::Sender"
or only to the first Open, OpenMultipart, MailMsg or MailFile!
=item skip_bad_recipients
If this option is set to false or not specified then Mail::Sender stops trying to send a message as soon as
the first recipient's address fails. If it is set to a true value Mail::Sender skips the bad addresses and tries
to send the message at least to the good ones. If all addresses are rejected by the server it reports an
"All recipients were rejected" message.
If any addresses were skipped the C<$sender-E<gt>{'skipped_recipients'}> will be a reference to a hash
containing the failed address and the server's response.
=item createmessageid
This option allows you to overwrite the function that generates the message IDs for the emails.
The function gets the "pure" sender's address as it's only parameter and is supposed to return a string.
See the MessageID subroutine in Mail::Sender.pm.
If you want to specify a message id you can also use the "messageid" parameter for the Open, OpenMultipart,
MailMsg or MailFile methods.
=item on_errors
This option allows you to affect the way Mail::Sender reports errors.
=> 'die' - raise an exception
=> 'code' - return the negative error code (default)
=> 'undef' - return an undef
$Mail::Sender::Error, $sender->{'error'} and $sender->{'error_msg'} are set in all the cases.
All methods return the $sender object if they succeed.
P.S.: The die_on_errors option is deprecated. You may still use it, but it may be removed in future versions!
=back
=head2 Return codes
ref to a Mail::Sender object = success
-1 = $smtphost unknown
-2 = socket() failed
-3 = connect() failed
-4 = service not available
-5 = unspecified communication error
-6 = local user $to unknown on host $smtp
-7 = transmission of message failed
-8 = argument $to empty
-9 = no message specified in call to MailMsg or MailFile
-10 = no file name specified in call to SendFile or MailFile
-11 = file not found
-12 = not available in singlepart mode
-13 = site specific error
-14 = connection not established. Did you mean MailFile instead of SendFile?
-15 = no SMTP server specified
-16 = no From: address specified
-17 = authentication protocol not accepted by the server
-18 = login not accepted
-19 = authentication protocol is not implemented
-20 = all recipients were rejected by the server
-21 = file specified as an attachment cannot be read
-22 = failed to open the specified debug file for writing
-23 = STARTTLS failed (for SSL or TLS encrypted connections)
-24 = IO::Socket::SSL->start_SSL failed
-25 = TLS required by the specified options, but the required modules are not available. Need IO::Socket::SSL and Net::SSLeay
-26 = TLS required by the specified options, but the server doesn't support it
-27 = unknown encoding specified for the mail body, part or attachment. Only base64, quoted-printable, 7bit and 8bit supported.
$Mail::Sender::Error contains a textual description of last error.
=cut
sub new {
my $this = shift;
my $self = {};
my $class;
if (ref($this)) {
$class = ref($this);
%$self = %$this;
} else {
$class = $this;
}
bless $self, $class;
return $self->initialize(@_);
}
sub initialize {
undef $Mail::Sender::Error;
my $self = shift;
delete $self->{'_buffer'};
$self->{'debug'} = 0;
$self->{'proto'} = (getprotobyname('tcp'))[2];
$self->{'port'} = getservbyname('smtp', 'tcp')||25 if not defined $self->{'port'};
$self->{'boundary'} = 'Message-Boundary-by-Mail-Sender-'.time();
$self->{'multipart'} = 'mixed'; # default is multipart/mixed
$self->{'tls_allowed'} = 1;
$self->{'client'} = $local_name;
# Copy defaults from %Mail::Sender::default
my $key;
foreach $key (keys %Mail::Sender::default) {
$self->{lc $key}=$Mail::Sender::default{$key};
}
if (@_ != 0) {
if (ref $_[0] eq 'HASH') {
my $hash=$_[0];
foreach $key (keys %$hash) {
$self->{lc $key}=$hash->{$key};
}
$self->{'reply'} = $self->{'replyto'} if (defined $self->{'replyto'} and !defined $self->{'reply'});
} else {
($self->{'from'}, $self->{'reply'}, $self->{'to'}, $self->{'smtp'},
$self->{'subject'}, $self->{'headers'}, $self->{'boundary'}
) = @_;
}
}
$self->{'fromaddr'} = $self->{'from'};
$self->{'replyaddr'} = $self->{'reply'};
$self->_prepare_addresses('to') if defined $self->{'to'};
$self->_prepare_addresses('cc') if defined $self->{'cc'};
$self->_prepare_addresses('bcc') if defined $self->{'bcc'};
$self->_prepare_ESMTP() if defined $self->{'esmtp'};
$self->{'fromaddr'} =~ s/.*<([^\s]*?)>/$1/ if ($self->{'fromaddr'}); # get from email address
if (defined $self->{'replyaddr'} and $self->{'replyaddr'}) {
$self->{'replyaddr'} =~ s/.*<([^\s]*?)>/$1/; # get reply email address
$self->{'replyaddr'} =~ s/^([^\s]+).*/$1/; # use first address
}
if (defined $self->{'smtp'}) {
$self->{'smtp'} =~ s/^\s+//g; # remove spaces around $smtp
$self->{'smtp'} =~ s/\s+$//g;
$self->{'smtpaddr'} = inet_aton($self->{'smtp'});
if (!defined($self->{'smtpaddr'})) { return $self->Error(HOSTNOTFOUND($self->{'smtp'})); }
$self->{'smtpaddr'} = $1 if ($self->{'smtpaddr'} =~ /(.*)/s); # Untaint
}
$self->{'boundary'} =~ tr/=/-/ if defined $self->{'boundary'};
$self->_prepare_headers() if (exists $self->{'headers'});
return $self;
}
use vars qw(%CTypes);
%CTypes = (
GIF => 'image/gif',
JPE => 'image/jpeg',
JPEG => 'image/jpeg',
SHTML => 'text/html',
SHTM => 'text/html',
HTML => 'text/html',
HTM => 'text/html',
TXT => 'text/plain',
INI => 'text/plain',
DOC => 'application/x-msword',
EML => 'message/rfc822',
);
sub GuessCType {
my $ext = shift;
$ext =~ s/^.*\.//;
return $CTypes{uc $ext} || 'application/octet-stream';
}
sub Connect {
my $self = shift();
my $s = IO::Socket::INET->new(
PeerHost => $self->{'smtp'},
PeerPort => $self->{'port'},
Proto => "tcp",
Timeout => ($self->{'timeout'} || 120),
) or return $self->Error(CONNFAILED);
$s->autoflush(1);
binmode($s);
if ($self->{'debug'}) {
eval {
$s = __Debug( $s, $self->{'debug'});
}
or return $self->Error(DEBUGFILE($@));
$self->{'debug_level'} = 4 unless defined $self->{'debug_level'};
}
$_ = get_response($s); if (not $_ or !/^[123]/) { return $self->Error(SERVNOTAVAIL($_)); }
$self->{'server'} = substr $_, 4;
$self->{'!greeting'} = $_;
{ my $res = $self->say_helo($s);
return $res if $res;
}
if (($self->{tls_required} or $self->{tls_allowed})
and ! $TLS_notsupported and (defined($self->{'supports'}{STARTTLS}) or defined($self->{'supports'}{TLS}))) {
Net::SSLeay::load_error_strings();
Net::SSLeay::SSLeay_add_ssl_algorithms();
$Net::SSLeay::random_device = $0 if (!-s $Net::SSLeay::random_device);
Net::SSLeay::randomize();
my $res=send_cmd $s, "STARTTLS";
my ($code,$text)=split(/\s/,$res,2);
return $self->Error(STARTTLS($code,$text)) if ($code != 220);
my %ssl_options = (
SSL_version =>'TLSv1',
SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE(),
);
if (exists $self->{ssl_version}) { $ssl_options{SSL_version} = $self->{ssl_version}; }
if (exists $self->{ssl_verify_mode}) { $ssl_options{SSL_verify_mode} = $self->{ssl_verify_mode}; }
if (exists $self->{ssl_ca_path}) { $ssl_options{SSL_ca_path} = $self->{ssl_ca_path}; }
if (exists $self->{ssl_ca_file}) { $ssl_options{SSL_ca_file} = $self->{ssl_ca_file}; }
if (exists $self->{ssl_verifycb_name}) { $ssl_options{SSL_verifycb_name} = $self->{ssl_verifycb_name}; }
if (exists $self->{ssl_verifycn_schema}) { $ssl_options{ssl_verifycn_schema} = $self->{ssl_verifycn_schema}; }
if (exists $self->{ssl_hostname}) { $ssl_options{SSL_hostname} = $self->{ssl_hostname}; }
if ($self->{'debug'}) {
#print "Debug: \$s=$s\ntied(\$s)=" . tied($s) . "\n\${tied(\$s)}=${tied($s)}\n";
#print "Debug: \$s=$s\n\${\$s}=" . ${$s} . "\n";
#use PSH;
#$::S = $s;
#PSH::prompt;
$res = IO::Socket::SSL->start_SSL( tied(*$s)->[0], %ssl_options)
} else {
$res = IO::Socket::SSL->start_SSL( $s, %ssl_options)
}
if (! $res) {
return $self->Error(IO_SOCKET_SSL(IO::Socket::SSL::errstr()));
}
{
my $res = $self->say_helo($s);
return $res if $res;
}
} elsif ($self->{tls_required}) {
if ($TLS_notsupported) {
return $self->Error(TLS_UNSUPPORTED_BY_ME($TLS_notsupported))
} else {
return $self->Error(TLS_UNSUPPORTED_BY_SERVER())
}
}
if ($self->{'auth'} or $self->{'username'}) {
$self->{'socket'} = $s;
my $res = $self->login();
return $res if $res;
delete $self->{'socket'}; # it's supposed to be added later
}
return $s;
}
sub Error {
my $self = shift();
if (@_) {
if (defined $self->{'socket'}) {
my $s = $self->{'socket'};
print $s "quit\x0D\x0A";
close $s;
delete $self->{'socket'};
}
delete $self->{'_data'};
($self->{'error'},$self->{'error_msg'}) = @_;
}
if ($self->{'die_on_errors'} or $self->{'on_errors'} eq 'die') {
die $self->{'error_msg'}."\n" ;
} elsif (exists $self->{'on_errors'} and (!defined($self->{'on_errors'}) or $self->{'on_errors'} eq 'undef')) {
return
} else {
return $self->{'error'}
}
}
sub ClearErrors {
my $self = shift();
delete $self->{'error'};
delete $self->{'error_msg'};
undef $Mail::Sender::Error;
}
sub _prepare_addresses {
my ($self, $type) = @_;
if (ref $self->{$type}) {
$self->{$type.'_list'} = [map {s/\s+$//;s/^\s+//;$_} @{$self->{$type}}];
$self->{$type} = join ', ', @{$self->{$type.'_list'}};
} else {
$self->{$type} =~ s/\s+/ /g;
$self->{$type} =~ s/, ?,/,/g;
$self->{$type.'_list'} = [map {s/\s+$//;$_} $self->{$type} =~ /((?:[^",]+|"[^"]*")+)(?:,\s*|\s*$)/g];
}
}
sub _prepare_ESMTP {
my $self = shift;
$self->{esmtp} = {%{$self->{esmtp}}}; # make a copy of the hash. Just in case
$self->{esmtp}{ORCPT} = 'rfc822;' . $self->{esmtp}{ORCPT} if $self->{esmtp}{ORCPT} ne '' and $self->{esmtp}{ORCPT} !~ /;/;
for (qw(ENVID ORCPT)) {
$self->{esmtp}{$_} = enc_xtext($self->{esmtp}{$_});
}
}
sub _prepare_headers {
my $self = shift;
return unless exists $self->{'headers'};
if ($self->{'headers'} eq '') {
delete $self->{'headers'};
delete $self->{'_headers'};
return;
}
if (ref($self->{'headers'}) eq 'HASH') {
my $headers = '';
while ( my ($hdr, $value) = each %{$self->{'headers'}}) {
for ($hdr, $value) {
s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg; # convert all end-of-lines to CRLF
s/^(?:\x0D\x0A)+//; # strip leading
s/(?:\x0D\x0A)+$//; # and trailing end-of-lines
s/\x0D\x0A(\S)/\x0D\x0A\t$1/sg;
if (length($_) > 997) { # header too long, max 1000 chars
s/(.{1,980}[;,])\s+(\S)/$1\x0D\x0A\t$2/g;
}
}
$headers .= "$hdr: $value\x0D\x0A";
}
$headers =~ s/(?:\x0D\x0A)+$//; # and trailing end-of-lines
$self->{'_headers'} = $headers;
} elsif (ref($self->{'headers'})) {
} else {
$self->{'_headers'} = $self->{'headers'};
for ($self->{'_headers'}) {
s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg; # convert all end-of-lines to CRLF
s/^(?:\x0D\x0A)+//; # strip leading
s/(?:\x0D\x0A)+$//; # and trailing end-of-lines
}
}
}
=head1 METHODS
=head2 Open
Open([from [, replyto [, to [, smtp [, subject [, headers]]]]]])
Open({[from => "somebody@somewhere.com"] , [to => "else@nowhere.com"] [,...]})
Opens a new message. If some parameters are unspecified or empty, it uses
the parameters passed to the "C<$Sender=new Mail::Sender(...)>";
See C<new Mail::Sender> for info about the parameters.
The only additional parameter that may not be specified directly in the C<new Mail::Sender>
is messageid. If you set this option then the message will be sent with this Message-ID,
otherwise a new Message ID will be generated out of the sender's address, current date+time
and a random number (or by the function you specified in the C<createmessageid> option).
After the message is sent C<$sender-E<gt>{messageid}> will contain the Message-ID with
which the message was sent.
Returns ref to the Mail::Sender object if successful.
=cut
sub Open {
undef $Mail::Sender::Error;
my $self = shift;
local $_;
if (!$self->{'keepconnection'} and $self->{'_data'}) { # the user did not Close() or Cancel() the previous mail
if ($self->{'error'}) {
$self->Cancel;
} else {
$self->Close;
}
}
delete $self->{'error'};
delete $self->{'encoding'};
delete $self->{'messageid'};
my %changed;
$self->{'multipart'} = 0;
$self->{'_had_newline'} = 1;
if (ref $_[0] eq 'HASH') {
my $key;
my $hash=$_[0];
$hash->{'reply'} = $hash->{'replyto'} if (defined $hash->{'replyto'} and !defined $hash->{'reply'});
foreach $key (keys %$hash) {
if (ref($hash->{$key}) eq 'HASH' and exists $self->{lc $key}) {
if (ref($self->{lc $key}) eq 'HASH') {
$self->{lc $key} = { %{$self->{lc $key}}, %{$hash->{$key}} };
} else {
$self->{lc $key} = { %{$hash->{$key}} }; # make a shallow copy
}
} else {
$self->{lc $key} = $hash->{$key};
}
$changed{lc $key}=1;
}
} else {
my ($from, $reply, $to, $smtp, $subject, $headers) = @_;
if ($from) {$self->{'from'}=$from;$changed{'from'}=1;}
if ($reply) {$self->{'reply'}=$reply;$changed{'reply'}=1;}
if ($to) {$self->{'to'}=$to;$changed{'to'}=1;}
if ($smtp) {$self->{'smtp'}=$smtp;$changed{'smtp'}=1;}
if ($subject) {$self->{'subject'}=$subject;$changed{'subject'}=1;}
if ($headers) {$self->{'headers'}=$headers;$changed{'headers'}=1;}
}
$self->_prepare_addresses('to') if $changed{'to'};
$self->_prepare_addresses('cc') if $changed{'cc'};
$self->_prepare_addresses('bcc') if $changed{'bcc'};
$self->_prepare_ESMTP() if defined $changed{'esmtp'};
$self->{'boundary'} =~ tr/=/-/ if defined $changed{'boundary'};
return $self->Error( NOFROMSPECIFIED) unless defined $self->{'from'};
if ($changed{'from'}) {
$self->{'fromaddr'} = $self->{'from'};
$self->{'fromaddr'} =~ s/.*<([^\s]*?)>/$1/; # get from email address
}
if ($changed{'reply'}) {
$self->{'replyaddr'} = $self->{'reply'};
$self->{'replyaddr'} =~ s/.*<([^\s]*?)>/$1/; # get reply email address
$self->{'replyaddr'} =~ s/^([^\s]+).*/$1/; # use first address
}
if ($changed{'smtp'}) {
$self->{'smtp'} =~ s/^\s+//g; # remove spaces around $smtp
$self->{'smtp'} =~ s/\s+$//g;
$self->{'smtpaddr'} = inet_aton($self->{'smtp'});
if (!defined($self->{'smtpaddr'})) { return $self->Error(HOSTNOTFOUND($self->{'smtp'})); }
$self->{'smtpaddr'} = $1 if ($self->{'smtpaddr'} =~ /(.*)/s); # Untaint
if (exists $self->{'socket'}) {
my $s = $self->{'socket'};
close $s;
delete $self->{'socket'};
}
}
$self->_prepare_headers() if ($changed{'headers'});
if (!$self->{'to'}) { return $self->Error(TOEMPTY); }
return $self->Error(NOSERVER) unless defined $self->{'smtp'};
# if (!defined($self->{'smtpaddr'})) { return $self->Error(HOSTNOTFOUND($self->{'smtp'})); }
if ($Mail::Sender::{'SiteHook'} and !$self->SiteHook()) {
return defined $self->{'error'} ? $self->{'error'} : $self->{'error'}=&SITEERROR;
}
my $s = $self->{'socket'} || $self->Connect();
return $s unless ref $s; # return the error number if we did not get a socket
$self->{'socket'} = $s;
$_ = send_cmd $s, "MAIL FROM:<$self->{'fromaddr'}>$self->{esmtp}{_MAIL_FROM}";
if (!/^[123]/) { return $self->Error(COMMERROR($_)); }
{ local $^W;
if ($self->{'skip_bad_recipients'}) {
my $good_count = 0;
my %failed;
foreach my $addr ( @{$self->{'to_list'}}, @{$self->{'cc_list'}}, @{$self->{'bcc_list'}}) {
if ($addr =~ /<(.*)>/) {
$_ = send_cmd $s, "RCPT TO:<$1>$self->{esmtp}{_RCPT_TO}";
} else {
$_ = send_cmd $s, "RCPT TO:<$addr>$self->{esmtp}{_RCPT_TO}";
}
if (!/^[123]/) {
chomp;
s/^\d{3} //;
$failed{$addr} = $_;
} else {
$good_count++
}
}
$self->{'skipped_recipients'} = \%failed
if %failed;
if ($good_count == 0) {
return $self->Error(ALLRECIPIENTSBAD);
}
} else {
foreach my $addr ( @{$self->{'to_list'}}, @{$self->{'cc_list'}}, @{$self->{'bcc_list'}}) {
if ($addr =~ /<(.*)>/) {
$_ = send_cmd $s, "RCPT TO:<$1>$self->{esmtp}{_RCPT_TO}";
} else {
$_ = send_cmd $s, "RCPT TO:<$addr>$self->{esmtp}{_RCPT_TO}";
}
if (!/^[123]/) {
return $self->Error(USERUNKNOWN($addr, $self->{'smtp'}, $_)); }
}
}
}
$_ = send_cmd $s, "DATA";
if (!/^[123]/) { return $self->Error(COMMERROR($_)); }
$self->{'socket'}->stop_logging("\x0D\x0A... message headers and data skipped ...") if ($self->{'debug'} and $self->{'debug_level'} <= 1);
$self->{'_data'} = 1;
$self->{'ctype'} = 'text/plain' if (defined $self->{'charset'} and !defined $self->{'ctype'});
my $headers;
if (defined $self->{'encoding'} or defined $self->{'ctype'}) {
$headers = 'MIME-Version: 1.0';
$headers .= "\r\nContent-Type: $self->{'ctype'}" if defined $self->{'ctype'};
$headers .= "; charset=$self->{'charset'}" if defined $self->{'charset'};
undef $self->{'chunk_size'};
if (defined $self->{'encoding'}) {
$headers .= "\r\nContent-Transfer-Encoding: $self->{'encoding'}";
if ($self->{'encoding'} =~ /Base64/i) {
$self->{'code'} = enc_base64($self->{'charset'});
$self->{'chunk_size'} = $enc_base64_chunk;
} elsif ($self->{'encoding'} =~ /Quoted[_\-]print/i) {
$self->{'code'} = enc_qp($self->{'charset'});
} elsif ($self->{'encoding'} =~ /^[78]bit$/i) {
$self->{'code'} = enc_plain($self->{charset})
} else {
return $self->Error(UNKNOWNENCODING($self->{'encoding'}));
}
}
}
$self->{'code'} = enc_plain($self->{charset}) unless $self->{'code'};
print_hdr $s, "To" => (defined $self->{'fake_to'} ? $self->{'fake_to'} : $self->{'to'}), $self->{'charset'};
print_hdr $s, "From" => (defined $self->{'fake_from'} ? $self->{'fake_from'} : $self->{'from'}), $self->{'charset'};
if (defined $self->{'fake_cc'} and $self->{'fake_cc'}) {
print_hdr $s, "Cc" => $self->{'fake_cc'}, $self->{'charset'};
} elsif (defined $self->{'cc'} and $self->{'cc'}) {
print_hdr $s, "Cc" => $self->{'cc'}, $self->{'charset'};
}
print_hdr $s, "Reply-To", $self->{'reply'},$self->{'charset'} if defined $self->{'reply'};
$self->{'subject'} = "<No subject>" unless defined $self->{'subject'};
print_hdr $s, "Subject" => $self->{'subject'}, $self->{'charset'};
unless (defined $Mail::Sender::NO_DATE and $Mail::Sender::NO_DATE
or
defined $self->{'_headers'} and $self->{'_headers'} =~ /^Date:/m
or
defined $Mail::Sender::SITE_HEADERS && $Mail::Sender::SITE_HEADERS =~ /^Date:/m
) {
my $date = localtime(); $date =~ s/^(\w+)\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)$/$1, $3 $2 $5 $4/;
print_hdr $s, "Date" => "$date $GMTdiff";
}
if ($self->{'priority'}) {
$self->{'priority'} = $priority[$self->{'priority'}]
if ($self->{'priority'}+0 eq $self->{'priority'});
print_hdr $s, "X-Priority" => $self->{'priority'};
}
if ($self->{'confirm'}) {
for my $confirm (split /\s*,\s*/, $self->{'confirm'}) {
if ($confirm =~ /^\s*reading\s*(?:\:\s*(.*))?/i) {
print_hdr $s, "X-Confirm-Reading-To" => ($1 || $self->{'from'}), $self->{'charset'};
} elsif ($confirm =~ /^\s*delivery\s*(?:\:\s*(.*))?/i) {
print_hdr $s, "Return-Receipt-To" => ($1 || $self->{'fromaddr'}), $self->{'charset'};
print_hdr $s, "Disposition-Notification-To" => ($1 || $self->{'fromaddr'}), $self->{'charset'};
}
}
}
unless (defined $Mail::Sender::NO_X_MAILER) {
my $script = basename($0);
print_hdr $s, "X-Mailer" => qq{Perl script "$script"\r\n\tusing Mail::Sender $Mail::Sender::ver by Jenda Krynicky, Czechlands\r\n\trunning on $local_name ($local_IP)\r\n\tunder account "}.getusername().qq{"\r\n}
}
unless (defined $Mail::Sender::NO_MESSAGE_ID and $Mail::Sender::NO_MESSAGE_ID) {
if (!defined $self->{'messageid'} or $self->{'messageid'} eq '') {
if (defined $self->{'createmessageid'} and ref $self->{'createmessageid'} eq 'CODE') {
$self->{'messageid'} = $self->{'createmessageid'}->($self->{'fromaddr'});
} else {
$self->{'messageid'} = MessageID($self->{'fromaddr'});
}
}
print_hdr $s, "Message-ID" => $self->{'messageid'};
}
print $s $Mail::Sender::SITE_HEADERS,"\x0D\x0A" #<???> should handle \r\n at the end of the headers
if (defined $Mail::Sender::SITE_HEADERS);
print $s $self->{'_headers'},"\x0D\x0A" if defined $self->{'_headers'} and $self->{'_headers'};
print $s $headers,"\r\n" if defined $headers;
print $s "\r\n";
$self->{'socket'}->stop_logging("... message data skipped ...") if ($self->{'debug'} and $self->{'debug_level'} <= 2);
return $self;
}
=head2 OpenMultipart
OpenMultipart([from [, replyto [, to [, smtp [, subject [, headers [, boundary]]]]]]])
OpenMultipart({[from => "somebody@somewhere.com"] , [to => "else@nowhere.com"] [,...]})
Opens a multipart message. If some parameters are unspecified or empty, it uses
the parameters passed to the C<$Sender=new Mail::Sender(...)>.
See C<new Mail::Sender> for info about the parameters.
Returns ref to the Mail::Sender object if successful.
=cut
sub OpenMultipart {
undef $Mail::Sender::Error;
my $self = shift;
local $_;
if (!$self->{'keepconnection'} and $self->{'_data'}) { # the user did not Close() or Cancel() the previous mail
if ($self->{'error'}) {
$self->Cancel;
} else {
$self->Close;
}
}
delete $self->{'error'};
delete $self->{'encoding'};
delete $self->{'messageid'};
$self->{'_part'} = 0;
my %changed;
if (defined $self->{'type'} and $self->{'type'}) {
$self->{'multipart'} = $1
if $self->{'type'} =~ m{^multipart/(.*)}i;
}
$self->{'multipart'} ='Mixed' unless $self->{'multipart'};
$self->{'idcounter'} = 0;
if (ref $_[0] eq 'HASH') {
my $key;
my $hash=$_[0];
$hash->{'multipart'} = $hash->{'subtype'} if defined $hash->{'subtype'};
$hash->{'reply'} = $hash->{'replyto'} if (defined $hash->{'replyto'} and !defined $hash->{'reply'});
foreach $key (keys %$hash) {
if ((ref($hash->{$key}) eq 'HASH') and exists($self->{lc $key})) {
if (ref($self->{lc $key}) eq 'HASH') {
$self->{lc $key} = { %{$self->{lc $key}}, %{$hash->{$key}} };
} else {
$self->{lc $key} = { %{$hash->{$key}} }; # make a shallow copy
}
} else {
$self->{lc $key} = $hash->{$key};
}
$changed{lc $key}=1;
}
} else {
my ($from, $reply, $to, $smtp, $subject, $headers, $boundary) = @_;
if ($from) {$self->{'from'}=$from;$changed{'from'}=1;}
if ($reply) {$self->{'reply'}=$reply;$changed{'reply'}=1;}
if ($to) {$self->{'to'}=$to;$changed{'to'}=1;}
if ($smtp) {$self->{'smtp'}=$smtp;$changed{'smtp'}=1;}
if ($subject) {$self->{'subject'}=$subject;$changed{'subject'}=1;}
if ($headers) {$self->{'headers'}=$headers;$changed{'headers'}=1;}
if ($boundary) {$self->{'boundary'}=$boundary;}
}
$self->_prepare_addresses('to') if $changed{'to'};
$self->_prepare_addresses('cc') if $changed{'cc'};
$self->_prepare_addresses('bcc') if $changed{'bcc'};
$self->_prepare_ESMTP() if defined $changed{'esmtp'};
$self->{'boundary'} =~ tr/=/-/ if $changed{'boundary'};
$self->_prepare_headers() if ($changed{'headers'});
return $self->Error( NOFROMSPECIFIED) unless defined $self->{'from'};
if ($changed{'from'}) {
$self->{'fromaddr'} = $self->{'from'};
$self->{'fromaddr'} =~ s/.*<([^\s]*?)>/$1/; # get from email address
}
if ($changed{'reply'}) {
$self->{'replyaddr'} = $self->{'reply'};
$self->{'replyaddr'} =~ s/.*<([^\s]*?)>/$1/; # get reply email address
$self->{'replyaddr'} =~ s/^([^\s]+).*/$1/; # use first address
}
if ($changed{'smtp'}) {
$self->{'smtp'} =~ s/^\s+//g; # remove spaces around $smtp
$self->{'smtp'} =~ s/\s+$//g;
$self->{'smtpaddr'} = inet_aton($self->{'smtp'});
if (!defined($self->{'smtpaddr'})) { return $self->Error(HOSTNOTFOUND($self->{'smtp'})); }
$self->{'smtpaddr'} = $1 if ($self->{'smtpaddr'} =~ /(.*)/s); # Untaint
if (exists $self->{'socket'}) {
my $s = $self->{'socket'};
close $s;
delete $self->{'socket'};
}
}
if (!$self->{'to'}) { return $self->Error(TOEMPTY); }
return $self->Error(NOSERVER) unless defined $self->{'smtp'};
# if (!defined($self->{'smtpaddr'})) { return $self->Error(HOSTNOTFOUND($self->{'smtp'})); }
if ($Mail::Sender::{'SiteHook'} and !$self->SiteHook()) {
return defined $self->{'error'} ? $self->{'error'} : $self->{'error'}=&SITEERROR;
}
my $s = $self->{'socket'} || $self->Connect();
return $s unless ref $s; # return the error number if we did not get a socket
$self->{'socket'} = $s;
$_ = send_cmd $s, "MAIL FROM:<$self->{'fromaddr'}>$self->{esmtp}{_MAIL_FROM}";
if (!/^[123]/) { return $self->Error(COMMERROR($_)); }
{ local $^W;
if ($self->{'skip_bad_recipients'}) {
my $good_count = 0;
my %failed;
foreach my $addr ( @{$self->{'to_list'}}, @{$self->{'cc_list'}}, @{$self->{'bcc_list'}}) {
if ($addr =~ /<(.*)>/) {
$_ = send_cmd $s, "RCPT TO:<$1>$self->{esmtp}{_RCPT_TO}";
} else {
$_ = send_cmd $s, "RCPT TO:<$addr>$self->{esmtp}{_RCPT_TO}";
}
if (!/^[123]/) {
s/^\d{3} //;
$failed{$addr} = $_;
} else {
$good_count++
}
}
$self->{'skipped_recipients'} = \%failed
if %failed;
if ($good_count == 0) {
return $self->Error(ALLRECIPIENTSBAD);
}
} else {
foreach my $addr ( @{$self->{'to_list'}}, @{$self->{'cc_list'}}, @{$self->{'bcc_list'}}) {
if ($addr =~ /<(.*)>/) {
$_ = send_cmd $s, "RCPT TO:<$1>$self->{esmtp}{_RCPT_TO}";
} else {
$_ = send_cmd $s, "RCPT TO:<$addr>$self->{esmtp}{_RCPT_TO}";
}
if (!/^[123]/) {
return $self->Error(USERUNKNOWN($addr, $self->{'smtp'}, $_));
}
}
}
}
$_ = send_cmd $s, "DATA";
if (!/^[123]/) { return $self->Error(COMMERROR($_)); }
$self->{'socket'}->stop_logging("\x0D\x0A... message headers and data skipped ...") if ($self->{'debug'} and $self->{'debug_level'} <= 1);
$self->{'_data'} = 1;
print_hdr $s, "To" => (defined $self->{'fake_to'} ? $self->{'fake_to'} : $self->{'to'}), $self->{'charset'};
print_hdr $s, "From" => (defined $self->{'fake_from'} ? $self->{'fake_from'} : $self->{'from'}), $self->{'charset'};
if (defined $self->{'fake_cc'} and $self->{'fake_cc'}) {
print_hdr $s, "Cc" => $self->{'fake_cc'}, $self->{'charset'};
} elsif (defined $self->{'cc'} and $self->{'cc'}) {
print_hdr $s, "Cc" => $self->{'cc'}, $self->{'charset'};
}
print_hdr $s, "Reply-To" => $self->{'reply'}, $self->{'charset'} if defined $self->{'reply'};
$self->{'subject'} = "<No subject>" unless defined $self->{'subject'};
print_hdr $s, "Subject" => $self->{'subject'}, $self->{'charset'};
unless (defined $Mail::Sender::NO_DATE and $Mail::Sender::NO_DATE
or
defined $self->{'_headers'} and $self->{'_headers'} =~ /^Date:/m
or
defined $Mail::Sender::SITE_HEADERS && $Mail::Sender::SITE_HEADERS =~ /^Date:/m
) {
my $date = localtime(); $date =~ s/^(\w+)\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)$/$1, $3 $2 $5 $4/;
print_hdr $s, "Date" => "$date $GMTdiff";
}
if ($self->{'priority'}) {
$self->{'priority'} = $priority[$self->{'priority'}]
if ($self->{'priority'}+0 eq $self->{'priority'});
print_hdr $s, "X-Priority" => $self->{'priority'};
}
if ($self->{'confirm'}) {
for my $confirm (split /\s*,\s*/, $self->{'confirm'}) {
if ($confirm =~ /^\s*reading\s*(?:\:\s*(.*))?/i) {
print_hdr $s, "X-Confirm-Reading-To" => ($1 || $self->{'from'}), $self->{'charset'};
} elsif ($confirm =~ /^\s*delivery\s*(?:\:\s*(.*))?/i) {
print_hdr $s, "Return-Receipt-To" => ($1 || $self->{'fromaddr'}), $self->{'charset'};
print_hdr $s, "Disposition-Notification-To" => ($1 || $self->{'fromaddr'}), $self->{'charset'};
}
}
}
unless (defined $Mail::Sender::NO_X_MAILER and $Mail::Sender::NO_X_MAILER) {
my $script = basename($0);
print_hdr $s, "X-Mailer" => qq{Perl script "$script"\r\n\tusing Mail::Sender $Mail::Sender::ver by Jenda Krynicky, Czechlands\r\n\trunning on $local_name ($local_IP)\r\n\tunder account "}.getusername().qq{"\r\n}
}
print $s $Mail::Sender::SITE_HEADERS,"\r\n"
if (defined $Mail::Sender::SITE_HEADERS);
unless (defined $Mail::Sender::NO_MESSAGE_ID and $Mail::Sender::NO_MESSAGE_ID) {
if (!defined $self->{'messageid'} or $self->{'messageid'} eq '') {
if (defined $self->{'createmessageid'} and ref $self->{'createmessageid'} eq 'CODE') {
$self->{'messageid'} = $self->{'createmessageid'}->($self->{'fromaddr'});
} else {
$self->{'messageid'} = MessageID($self->{'fromaddr'});
}
}
print_hdr $s, "Message-ID" => $self->{'messageid'};
}
print $s $self->{'_headers'},"\r\n" if defined $self->{'_headers'} and $self->{'_headers'};
print $s "MIME-Version: 1.0\r\n";
print_hdr $s, "Content-Type", qq{multipart/$self->{'multipart'};\r\n\tboundary="$self->{'boundary'}"};
print $s "\r\n";
$self->{'socket'}->stop_logging("... message data skipped ...") if ($self->{'debug'} and $self->{'debug_level'} <= 2);
print $s "This message is in MIME format. Since your mail reader does not understand\r\n"
. "this format, some or all of this message may not be legible.\r\n"
. "\r\n--$self->{'boundary'}\r\n";
return $self;
}
sub Connected {
my $self = shift();
return unless exists $self->{'socket'} and $self->{'socket'};
my $s = $self->{'socket'};
return $s->opened();
}
=head2 MailMsg
MailMsg([from [, replyto [, to [, smtp [, subject [, headers]]]]]], message)
MailMsg({[from => "somebody@somewhere.com"]
[, to => "else@nowhere.com"] [,...], msg => "Message"})
Sends a message. If a mail in $sender is opened it gets closed
and a new mail is created and sent. $sender is then closed.
If some parameters are unspecified or empty, it uses
the parameters passed to the "C<$Sender=new Mail::Sender(...)>";
See C<new Mail::Sender> for info about the parameters.
The module was made so that you could create an object initialized with
all the necesary options and then send several messages without need to
specify the SMTP server and others each time. If you need to send only
one mail using MailMsg() or MailFile() you do not have to create a named
object and then call the method. You may do it like this :
(new Mail::Sender)->MailMsg({smtp => 'mail.company.com', ...});
Returns ref to the Mail::Sender object if successful.
=cut
sub MailMsg {
my $self = shift;
my $msg;
local $_;
if (ref $_[0] eq 'HASH') {
my $hash=$_[0];
$msg=$hash->{'msg'};
} else {
$msg = pop;
}
return $self->Error(NOMSG) unless $msg;
if (ref $self->Open(@_)
and
ref $self->SendEnc($msg)
and
ref $self->Close()
) {
return $self
} else {
return $self->{'error'}
}
}
=head2 MailFile
MailFile([from [, replyto [, to [, smtp [, subject [, headers]]]]]], message, file(s))
MailFile({[from => "somebody@somewhere.com"]
[, to => "else@nowhere.com"] [,...],
msg => "Message", file fs=> "File"})
Sends one or more files by mail. If a mail in $sender is opened it gets closed
and a new mail is created and sent. $sender is then closed.
If some parameters are unspecified or empty, it uses
the parameters passed to the "C<$Sender=new Mail::Sender(...)>";
The C<file> parameter may be a "filename", a "list, of, file, names" or a \@list_of_file_names.
see C<new Mail::Sender> for info about the parameters.
Just keep in mind that parameters like ctype, charset and encoding
will be used for the attached file, not the body of the message.
If you want to specify those parameters for the body you have to use
b_ctype, b_charset and b_encoding. Sorry.
Returns ref to the Mail::Sender object if successful.
=cut
sub MailFile {
my $self = shift;
my $msg;
local $_;
my ($file, $desc, $haddesc,$ctype,$charset,$encoding);
my @files;
my $hash;
if (ref $_[0] eq 'HASH') {
$hash = {%{$_[0]}}; # make a copy
$msg = delete $hash->{'msg'};
$file=delete $hash->{'file'};
$desc=delete $hash->{'description'}; $haddesc = 1 if defined $desc;
$ctype=delete $hash->{'ctype'};
$charset=delete $hash->{'charset'};
$encoding=delete $hash->{'encoding'};
} else {
$desc=pop if ($#_ >=2); $haddesc = 1 if defined $desc;
$file = pop;
$msg = pop;
}
return $self->Error(NOMSG) unless $msg;
return $self->Error(NOFILE) unless $file;
if (ref $file eq 'ARRAY') {
@files=@$file;
} elsif ($file =~ /,/) {
@files=split / *, */,$file;
} else {
@files = ($file);
}
foreach $file (@files) {
return $self->Error(FILENOTFOUND($file)) unless ($file =~ /^&/ or -e $file);
}
ref $self->OpenMultipart($hash ? $hash : @_)
and
ref $self->Body(
$self->{'b_charset'}||$self->{'charset'},
$self->{'b_encoding'},
$self->{'b_ctype'}
)
and
$self->SendEnc($msg)
or return $self->{'error'};
$Mail::Sender::Error = '';
foreach $file (@files) {
my $cnt;
my $filename = basename $file;
my $ctype = $ctype || GuessCType $filename, $file;
my $encoding = $encoding || ($ctype =~ m#^text/#i ? 'Quoted-printable' : 'Base64');
$desc = $filename unless (defined $haddesc);
$self->Part({encoding => $encoding,
disposition => (defined $self->{'disposition'} ? $self->{'disposition'} : "attachment; filename=\"$filename\""),
ctype => ($ctype =~ /;\s*name(?:\*(?:0\*?)?)?=/ ? $ctype : "$ctype; name=\"$filename\"") . (defined $charset ? "; charset=$charset" : ''),
description => $desc});
my $code = $self->{'code'};
my $FH = new FileHandle;
open $FH, "<", $file
or return $self->Error(FILECANTREAD($file));
binmode $FH unless $ctype =~ m#^text/#i and $encoding =~ /Quoted[_\-]print|Base64/i;
my $s;
$s = $self->{'socket'};
my $mychunksize = $chunksize;
$mychunksize = $chunksize64 if defined $self->{'chunk_size'};
while (read $FH, $cnt, $mychunksize) {
$cnt = &$code($cnt);
$cnt =~ s/^\.\././ unless $self->{'_had_newline'};
print $s $cnt;
$self->{'_had_newline'} = ($cnt =~ /[\n\r]$/);
}
close $FH;
}
if ($Mail::Sender::Error eq '') {
undef $Mail::Sender::Error;
} else {
chomp $Mail::Sender::Error;
}
return $self->Close;
}
=head2 Send
Send(@strings)
Prints the strings to the socket. Doesn't add any end-of-line characters.
Doesn't encode the data! You should use C<\r\n> as the end-of-line!
UNLESS YOU ARE ABSOLUTELY SURE YOU KNOW WHAT YOU ARE DOING
YOU SHOULD USE SendEnc() INSTEAD!
Returns the object if successful.
=cut
sub Send {
my $self = shift;
my $s;
$s = $self->{'socket'};
print $s @_;
return $self;
}
=head2 SendLine
SendLine(@strings)
Prints the strings to the socket. Adds the end-of-line character at the end.
Doesn't encode the data! You should use C<\r\n> as the end-of-line!
UNLESS YOU ARE ABSOLUTELY SURE YOU KNOW WHAT YOU ARE DOING
YOU SHOULD USE SendLineEnc() INSTEAD!
Returns the object if successful.
=cut
sub SendLine {
my $self = shift;
my $s = $self->{'socket'};
print $s (@_,"\x0D\x0A");
return $self;
}
=head2 print
Alias to SendEnc().
Keep in mind that you can't write :
print $sender "...";
you have to use
$sender->print("...");
If you want to be able to print into the message as if it was a normal file handle take a look at C<GetHandle>()
=head2 SendEnc
SendEnc(@strings)
Prints the strings to the socket. Doesn't add any end-of-line characters.
Encodes the text using the selected encoding (none/Base64/Quoted-printable)
Returns the object if successful.
=cut
sub SendEnc {
my $self = shift;
local $_;
my $code = $self->{'code'};
$self->{'code'}= $code = enc_plain($self->{'charset'})
unless defined $code;
my $s;
$s = $self->{'socket'}
or return $self->Error(NOTCONNECTED);
if (defined $self->{'chunk_size'}) {
my $str;
my $chunk = $self->{'chunk_size'};
if (defined $self->{'_buffer'}) {
$str=(join '',($self->{'_buffer'},@_));
} else {
$str=join '',@_;
}
my ($len,$blen);
$len = length $str;
if (($blen=($len % $chunk)) >0) {
$self->{'_buffer'} = substr($str,($len-$blen));
print $s (&$code(substr( $str,0,$len-$blen)));
} else {
delete $self->{'_buffer'};
print $s (&$code($str));
}
} else {
my $encoded = &$code(join('',@_));
$encoded =~ s/^\.\././ unless $self->{'_had_newline'};
print $s $encoded;
$self->{'_had_newline'} = ($_[-1] =~ /[\n\r]$/);
}
return $self;
}
sub print;*print = \&SendEnc;
=head2 SendLineEnc
SendLineEnc(@strings)
Prints the strings to the socket and adds the end-of-line character at the end.
Encodes the text using the selected encoding (none/Base64/Quoted-printable).
Do NOT mix up /Send(Line)?(Ex)?/ and /Send(Line)?Enc/! SendEnc does some buffering
necessary for correct Base64 encoding, and /Send(Ex)?/ is not aware of that!
Usage of /Send(Line)?(Ex)?/ in non xBIT parts not recommended.
Using C<Send(encode_base64($string))> may work, but more likely it will not!
In particular if you use several such to create one part,
the data is very likely to get crippled.
Returns the object if successful.
=cut
sub SendLineEnc {
push @_, "\r\n";
goto &SendEnc;
}
=head2 SendEx
SendEx(@strings)
Prints the strings to the socket. Doesn't add any end-of-line characters.
Changes all end-of-lines to C<\r\n>. Doesn't encode the data!
UNLESS YOU ARE ABSOLUTELY SURE YOU KNOW WHAT YOU ARE DOING
YOU SHOULD USE SendEnc() INSTEAD!
Returns the object if successful.
=cut
sub SendEx {
my $self = shift;
my $s;
$s = $self->{'socket'}
or return $self->Error(NOTCONNECTED);
my $str;my @data = @_;
foreach $str (@data) {
$str =~ s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg;
$str =~ s/^\./../mg;
}
print $s @data;
return $self;
}
=head2 SendLineEx
SendLineEx(@strings)
Prints the strings to the socket. Adds an end-of-line character at the end.
Changes all end-of-lines to C<\r\n>. Doesn't encode the data!
UNLESS YOU ARE ABSOLUTELY SURE YOU KNOW WHAT YOU ARE DOING
YOU SHOULD USE SendEnc() INSTEAD!
Returns the object if successful.
=cut
sub SendLineEx {
push @_, "\r\n";
goto &SendEx;
}
=head2 Part
Part( I<description>, I<ctype>, I<encoding>, I<disposition> [, I<content_id> [, I<msg>]]);
Part( {[description => "desc"], [ctype => "content/type"], [encoding => "..."],
[disposition => "..."], [content_id => "..."], [msg => ...]});
Prints a part header for the multipart message and (if specified) the contents.
The undefined or empty variables are ignored.
=over 2
=item description
The title for this part.
=item ctype
the content type (MIME type) of this part. May contain some other
parameters, such as B<charset> or B<name>.
Defaults to "application/octet-stream".
Since 0.8.00 you may use even "multipart/..." types. Such a multipart part should be
closed by a call to $sender->EndPart($ctype).
...
$sender->Part({ctype => "multipart/related", ...});
$sender->Part({ctype => 'text/html', ...});
$sender->Attach({file => 'some_image.gif', content_id => 'foo', ...});
$sender->EndPart("multipart/related");
...
Please see the examples below.
=item encoding
the encoding used for this part of message. Eg. Base64, Uuencode, 7BIT
...
Defaults to "7BIT".
=item disposition
This parts disposition. Eg: 'attachment; filename="send.pl"'.
Defaults to "attachment". If you specify "none" or "", the
Content-Disposition: line will not be included in the headers.
=item content_id
The content id of the part, used in multipart/related.
If not specified, the header is not included.
=item msg
The content of the part. You do not have to specify the content here, you may use SendEnc()
to add content to the part.
=item charset
The charset of the part.
=back
Returns the Mail::Sender object if successful, negative error code if not.
=cut
sub Part {
my $self = shift;
local $_;
if (! $self->{'multipart'}) { return $self->Error(NOTMULTIPART("\$sender->Part()")); }
$self->EndPart();
my ($description, $ctype, $encoding, $disposition, $content_id, $msg, $charset);
if (ref $_[0] eq 'HASH') {
my $hash=$_[0];
$description=$hash->{'description'};
$ctype=$hash->{'ctype'};
$encoding=$hash->{'encoding'};
$disposition=$hash->{'disposition'};
$content_id = $hash->{'content_id'};
$msg = $hash->{'msg'};
$charset = $hash->{'charset'};
} else {
($description, $ctype, $encoding, $disposition, $content_id, $msg) = @_;
}
$ctype = "application/octet-stream" unless defined $ctype;
$disposition = "attachment" unless defined $disposition;
$encoding="7BIT" unless defined $encoding;
$self->{'encoding'} = $encoding;
if (defined $charset and $charset and $ctype !~ /charset=/i) {
$ctype .= qq{; charset="$charset"}
} elsif (!defined $charset and $ctype =~ /charset="([^"]+)"/) {
$charset = $1;
}
my $s;
$s = $self->{'socket'}
or return $self->Error(NOTCONNECTED);
undef $self->{'chunk_size'};
if ($encoding =~ /Base64/i) {
$self->{'code'} = enc_base64($charset);
$self->{'chunk_size'} = $enc_base64_chunk;
} elsif ($encoding =~ /Quoted[_\-]print/i) {
$self->{'code'} = enc_qp($charset);
} else {
$self->{'code'} = enc_plain($charset);
}
$self->{'socket'}->start_logging() if ($self->{'debug'} and $self->{'debug_level'} == 3);
if ($ctype =~ m{^multipart/}i) {
$self->{'_part'}+=2;
print $s "Content-Type: $ctype; boundary=\"Part-$self->{'boundary'}_$self->{'_part'}\"\r\n\r\n";
} else {
$self->{'_part'}++;
print $s "Content-Type: $ctype\r\n";
if ($description) {print $s "Content-Description: $description\r\n";}
print $s "Content-Transfer-Encoding: $encoding\r\n";
print $s "Content-Disposition: $disposition\r\n" unless $disposition eq '' or uc($disposition) eq 'NONE';
print $s "Content-ID: <$content_id>\r\n" if (defined $content_id);
print $s "\r\n";
$self->{'socket'}->stop_logging("... data skipped ...") if ($self->{'debug'} and $self->{'debug_level'} == 3);
$self->SendEnc($msg) if defined $msg;
}
#$self->{'_had_newline'} = 1;
return $self;
}
=head2 Body
Body([charset [, encoding [, content-type]]]);
Body({charset => '...', encoding => '...', ctype => '...', msg => '...');
Sends the head of the multipart message body. You can specify the
charset and the encoding. Default is "US-ASCII","7BIT",'text/plain'.
If you pass undef or zero as the parameter, this function uses the default
value:
Body(0,0,'text/html');
Returns the Mail::Sender object if successful, negative error code if not.
You should NOT use this method in single part messages, that is, it works after OpenMultipart(),
but has no meaning after Open()!
=cut
sub Body {
my $self = shift;
if (! $self->{'multipart'}) {
# ->Body() has no meanin in singlepart messages
if (@_) {
# they called it with some parameters? Too late for them, let's scream.
return $self->Error(NOTMULTIPART("\$sender->Body()"));
} else {
# $sender->Body() ... OK, let's ignore it.
return $self;
}
}
my $hash;
$hash = shift() if (ref $_[0] eq 'HASH');
my $charset = shift || $hash->{'charset'} || 'US-ASCII';
my $encoding = shift || $hash->{'encoding'} || $self->{'encoding'} || '7BIT';
my $ctype = shift || $hash->{'ctype'} || $self->{'ctype'} || 'text/plain';
$ctype .= qq{; charset="$charset"}
unless $ctype =~ /charset=/i;
$self->{'encoding'} = $encoding;
$self->{'ctype'} = $ctype;
$self->Part("Mail message body", $ctype,
$encoding, 'inline', undef, $hash->{'msg'});
return $self;
}
=head2 SendFile
Alias to Attach()
=head2 Attach
Attach( I<description>, I<ctype>, I<encoding>, I<disposition>, I<file>);
Attach( { [description => "desc"] , [ctype => "ctype"], [encoding => "encoding"],
[disposition => "disposition"], file => "file"});
Sends a file as a separate part of the mail message. Only in multipart mode.
=over 2
=item description
The title for this part.
=item ctype
the content type (MIME type) of this part. May contain some other
parameters, such as B<charset> or B<name>.
Defaults to "application/octet-stream".
=item encoding
the encoding used for this part of message. Eg. Base64, Uuencode, 7BIT
...
Defaults to "Base64".
=item disposition
This parts disposition. Eg: 'attachment; filename="send.pl"'. If you use
'attachment; filename=*' the * will be replaced by the respective names
of the sent files.
Defaults to "attachment; filename=*". If you do not want to include this header use
"" as the value.
=item file
The name of the file to send or a 'list, of, names' or a
['reference','to','a','list','of','filenames']. Each file will be sent as
a separate part.
Please keep in mind that if you pass a string as this parameter the module
will split it on commas! If your filenames may contain commas and you
want to be sure they are sent correctly you have to use the reference to array
format:
file => [ $filename],
=item content_id
The content id of the message part. Used in multipart/related.
Special values:
"*" => the name of the file
"#" => autoincremented number (starting from 0)
=back
Returns the Mail::Sender object if successful, negative error code if not.
=cut
sub SendFile {
my $self = shift;
local $_;
if (! $self->{'multipart'}) { return $self->Error(NOTMULTIPART("\$sender->SendFile()")); }
if (! $self->{'socket'}) { return $self->Error(NOTCONNECTED); }
my ($description, $ctype, $encoding, $disposition, $file, $content_id, @files);
if (ref $_[0] eq 'HASH') {
my $hash=$_[0];
$description=$hash->{'description'};
$ctype=$hash->{'ctype'};
$encoding=$hash->{'encoding'};
$disposition=$hash->{'disposition'};
$file=$hash->{'file'};
$content_id=$hash->{'content_id'};
} else {
($description, $ctype, $encoding, $disposition, $file, $content_id) = @_;
}
return ($self->{'error'}=NOFILE) unless $file;
if (ref $file eq 'ARRAY') {
@files=@$file;
} elsif ($file =~ /,/) {
@files=split / *, */,$file;
} else {
@files = ($file);
}
foreach $file (@files) {
return $self->Error(FILENOTFOUND($file)) unless ($file =~ /^&/ or -e $file);
}
$disposition = "attachment; filename=*" unless defined $disposition;
$encoding='Base64' unless $encoding;
my $s=$self->{'socket'};
if ($self->{'_buffer'}) {
my $code = $self->{'code'};
print $s (&$code($self->{'_buffer'}));
delete $self->{'_buffer'};
}
my $code;
if ($encoding =~ /Base64/i) {
$code = enc_base64();
} elsif ($encoding =~ /Quoted[_\-]print/i) {
$code = enc_qp();
} else {
$code = enc_plain();
}
$self->{'code'}=$code;
foreach $file (@files) {
$self->EndPart();$self->{'_part'}++;
$self->{'encoding'} = $encoding;
my $cnt='';
my $name = basename $file;
my $fctype = $ctype ? $ctype : GuessCType $name, $file;
$self->{'ctype'} = $fctype;
$self->{'socket'}->start_logging() if ($self->{'debug'} and $self->{'debug_level'} == 3);
if ($fctype =~ /;\s*name(?:\*(?:0\*?)?)?=/) { # looking for name=, name*=, name*0= or name*0*=
print $s ("Content-Type: $fctype\r\n");
} else {
print $s ("Content-Type: $fctype; name=\"$name\"\r\n");
}
if ($description) {print $s ("Content-Description: $description\r\n");}
print $s ("Content-Transfer-Encoding: $encoding\r\n");
if ($disposition =~ /^(.*)filename=\*(.*)$/i) {
print $s ("Content-Disposition: ${1}filename=\"$name\"$2\r\n");
} elsif ($disposition and uc($disposition) ne 'NONE') {
print $s ("Content-Disposition: $disposition\r\n");
}
if ($content_id) {
if ($content_id eq '*') {
print $s ("Content-ID: <$name>\r\n");
} elsif ($content_id eq '#') {
print $s ("Content-ID: <id".$self->{'idcounter'}++.">\r\n");
} else {
print $s ("Content-ID: <$content_id>\r\n");
}
}
print $s "\r\n";
$self->{'socket'}->stop_logging("... data skipped ...") if ($self->{'debug'} and $self->{'debug_level'} == 3);
my $FH = new FileHandle;
open $FH, "<", $file
or return $self->Error(FILECANTREAD($file));
binmode $FH unless $fctype =~ m#^text/#i and $encoding =~ /Quoted[_\-]print|Base64/i;
my $mychunksize = $chunksize;
$mychunksize = $chunksize64 if lc($encoding) eq "base64";
my $s;
$s = $self->{'socket'}
or return $self->Error(NOTCONNECTED);
while (read $FH, $cnt, $mychunksize) {
print $s (&$code($cnt));
}
close $FH;
}
return $self;
}
sub Attach; *Attach = \&SendFile;
=head2 EndPart
$sender->EndPart($ctype);
Closes a multipart part.
If the $ctype is not present or evaluates to false, only the current SIMPLE part is closed!
Don't do that unless you are really sure you know what you are doing.
It's best to always pass to the ->EndPart() the content type of the corresponding ->Part().
=cut
sub EndPart {
my $self = shift;
return unless $self->{'_part'};
my $end = shift();
my $s;
my $LN = "\x0D\x0A";
$s = $self->{'socket'}
or return $self->Error(NOTCONNECTED);
# flush the buffer (if it contains anything)
if ($self->{'_buffer'}) { # used only for base64
my $code = $self->{'code'};
if (defined $code) {
print $s (&$code($self->{'_buffer'}));
} else {
print $s ($self->{'_buffer'});
}
delete $self->{'_buffer'};
}
if ($self->{'_had_newline'}) {
$LN = '';
} else {
print $s "=" if !$self->{'bypass_outlook_bug'} and $self->{'encoding'} =~ /Quoted[_\-]print/i; # make sure we do not add a newline
}
$self->{'socket'}->start_logging() if ($self->{'debug'} and $self->{'debug_level'} == 3);
if ($self->{'_part'}>1) { # end of a subpart
print $s "$LN--Part-$self->{'boundary'}_$self->{'_part'}",
($end ? "--" : ()),
"\r\n";
} else {
print $s "$LN--$self->{'boundary'}",
($end ? "--" : ()),
"\r\n";
}
$self->{'_part'}--;
$self->{'code'} = enc_plain($self->{'charset'});
$self->{'encoding'} = '';
return $self;
}
=head2 Close
$sender->Close;
$sender->Close(1);
Close and send the email message. If you pass a true value to the method the connection will be closed even
if the "keepconnection" was specified. You should only keep the connection open if you plan to send another
message immediately. And you should not keep it open for hundreds of emails even if you do send them all in a row.
This method should be called automatically when destructing the object, but you should not rely on it. If you want to be sure
your message WAS processed by the SMTP server you SHOULD call Close() explicitely.
Returns the Mail::Sender object if successful, negative error code if not, zero if $sender was not connected at all.
The zero usually means that the Open/OpenMultipart failed and you did not test its return value.
=cut
sub Close {
my $self = shift;
local $_;
my $s = $self->{'socket'};
return 0 unless $s;
if ($self->{'_data'}) {
# flush the buffer (if it contains anything)
if ($self->{'_buffer'}) {
my $code = $self->{'code'};
if (defined $code) {
print $s (&$code($self->{'_buffer'}));
} else {
print $s ($self->{'_buffer'});
}
delete $self->{'_buffer'};
}
if ($self->{'_part'}) {
while ($self->{'_part'}) {
$self->EndPart(1);
}
}
$self->{'socket'}->start_logging() if ($self->{'debug'});
print $s "\r\n.\r\n" ;
$self->{'_data'} = 0;
$_ = get_response($s); if (/^[45]\d* (.*)$/) { return $self->Error(TRANSFAILED($1)); }
$self->{message_response} = $_;
}
delete $self->{'encoding'};
delete $self->{'ctype'};
if ($_[0] or !$self->{'keepconnection'}) {
$_ = send_cmd $s, "QUIT";
if (!/^[123]/) { return $self->Error(COMMERROR($_)); }
close $s;
delete $self->{'socket'};
delete $self->{'debug'};
}
return $self;
}
=head2 Cancel
$sender->Cancel;
Cancel an opened message.
SendFile and other methods may set $sender->{'error'}.
In that case "undef $sender" calls C<$sender->>Cancel not C<$sender->>Close!!!
Returns the Mail::Sender object if successful, negative error code if not.
=cut
sub Cancel {
my $self = shift;
my $s;
$s = $self->{'socket'}
or return $self->Error(NOTCONNECTED);
close $s;
delete $self->{'socket'};
delete $self->{'error'};
return $self;
}
sub DESTROY {
return if ref($_[0]) ne 'Mail::Sender';
my $self = shift;
if (defined $self->{'socket'}) {
delete $self->{'keepconnection'};
$self->Close;
}
}
sub MessageID {
my $from = shift;
my ($sec,$min,$hour,$mday,$mon,$year)
= gmtime(time);
$mon++;$year+=1900;
return sprintf "<%04d%02d%02d_%02d%02d%02d_%06d.%s>",
$year,$mon,$mday,$hour,$min,$sec,rand(100000),
$from;
}
=head2 QueryAuthProtocols
@protocols = $sender->QueryAuthProtocols();
@protocols = $sender->QueryAuthProtocols( $smtpserver);
Queryies the server (specified either in the default options for Mail::Sender,
the "new Mail::Sender" command or as a parameter to this method for
the authentication protocols it supports.
=cut
sub QueryAuthProtocols {
my $self = shift;
local $_;
if (!defined $self) {
croak "Mail::Sender::QueryAuthProtocols() called without any parameter!";
} elsif (ref $self) { # $sender->QueryAuthProtocols() or $sender->QueryAuthProtocols('the.server.com)
if ($self->{'socket'}) { # the user did not Close() or Cancel() the previous mail
die "You forgot to close the mail before calling QueryAuthProtocols!\n"
}
if (@_) {
$self->{'smtp'} = shift();
$self->{'smtp'} =~ s/^\s+//g; # remove spaces around $smtp
$self->{'smtp'} =~ s/\s+$//g;
$self->{'smtpaddr'} = inet_aton($self->{'smtp'});
if (!defined($self->{'smtpaddr'})) { return $self->Error(HOSTNOTFOUND($self->{'smtp'})); }
$self->{'smtpaddr'} = $1 if ($self->{'smtpaddr'} =~ /(.*)/s); # Untaint
}
} elsif ($self =~ /::/) { # Mail::Sender->QueryAuthProtocols('the.server.com')
croak "Mail::Sender->QueryAuthProtocols() called without any parameter!"
if ! @_;
$self = new Mail::Sender {smtp => $_[0]};
return unless ref $self;
} else { # Mail::Sender::QueryAuthProtocols('the.server.com')
$self = new Mail::Sender {smtp => $self};
return unless ref $self;
}
return $self->Error(NOSERVER) unless defined $self->{'smtp'};
my $s = IO::Socket::INET->new(
PeerHost => $self->{'smtp'},
PeerPort => $self->{'port'},
Proto => "tcp",
Timeout => $self->{'timeout'} || 120,
) or return $self->Error(CONNFAILED);
$s->autoflush(1);
$_ = get_response($s); if (not $_ or !/^[123]/) { return $self->Error(SERVNOTAVAIL($_)); }
$self->{'server'} = substr $_, 4;
{ my $res = $self->say_helo($s);
return $res if $res;
}
$_ = send_cmd $s, "QUIT";
close $s;
delete $self->{'socket'};
if (wantarray) {
return keys %{$self->{'auth_protocols'}};
} else {
my $key = each %{$self->{'auth_protocols'}};
return $key;
}
}
sub printAuthProtocols {
print "$_[1] supports: ",join(", ", Mail::Sender->QueryAuthProtocols($_[1] || 'localhost')),"\n";
}
sub TestServer {
my $self = shift;
local $_;
if (!defined $self) {
croak "Mail::Sender::TestServer() called without any parameter!";
} elsif (ref $self) { # $sender->TestServer() or $sender->TestServer('the.server.com)
if ($self->{'socket'}) { # the user did not Close() or Cancel() the previous mail
die "You forgot to close the mail before calling TestServer!\n"
}
if (@_) {
$self->{'smtp'} = shift();
$self->{'smtp'} =~ s/^\s+//g; # remove spaces around $smtp
$self->{'smtp'} =~ s/\s+$//g;
$self->{'smtpaddr'} = inet_aton($self->{'smtp'});
if (!defined($self->{'smtpaddr'})) { return $self->Error(HOSTNOTFOUND($self->{'smtp'})); }
$self->{'smtpaddr'} = $1 if ($self->{'smtpaddr'} =~ /(.*)/s); # Untaint
}
$self->{'on_errors'} = 'die';
} elsif ($self =~ /::/) { # Mail::Sender->TestServer('the.server.com')
croak "Mail::Sender->TestServer() called without any parameter!"
if ! @_;
$self = new Mail::Sender {smtp => $_[0], on_errors => 'die'};
return unless ref $self;
} else { # Mail::Sender::QueryAuthProtocols('the.server.com')
$self = new Mail::Sender {smtp => $self, on_errors => 'die'};
return unless ref $self;
}
return $self->Error(NOSERVER) unless defined $self->{'smtp'};
# if (!defined($self->{'smtpaddr'})) { return $self->Error(HOSTNOTFOUND($self->{'smtp'})); }
if (exists $self->{'on_errors'} and (!defined($self->{'on_errors'}) or $self->{'on_errors'} eq 'undef')) {
return ($self->Connect() and $self->Close() and 1);
} elsif (exists $self->{'on_errors'} and $self->{'on_errors'} eq 'die') {
$self->Connect();
$self->Close();
return 1;
} else {
my $res = $self->Connect();
return $res unless ref $res;
$res = $self->Close();
return $res unless ref $res;
return $self;
}
}
#====== Debuging bazmecks
$debug_code = <<'*END*';
package Mail::Sender::DBIO;
use IO::Handle;
use Tie::Handle;
@Mail::Sender::DBIO::ISA = qw(Tie::Handle);
sub SOCKET () {0}
sub LOG () {1}
sub ENDLINE () {2}
sub CLOSELOG () {3}
sub OFF () {4}
sub TIEHANDLE {
my ($pkg,$socket,$debughandle, $mayCloseLog) = @_;
return bless [$socket,$debughandle,1, $mayCloseLog,0], $pkg;
}
sub PRINT {
my $self = shift;
my $text = join(($\ || ''), @_);
$self->[SOCKET]->print($text);
return if $self->[OFF];
$text =~ s/\x0D\x0A(?=.)/\x0D\x0A<< /g;
$text = "<< ".$text if $self->[ENDLINE];
$self->[ENDLINE] = ($text =~ /\x0D\x0A$/);
$self->[LOG]->print($text);
}
sub READLINE {
my $self = shift();
my $socket = $self->[SOCKET];
my $line = <$socket>;
$self->[LOG]->print(">> $line") if defined $line and !$self->[OFF];
return $line;
}
sub CLOSE {
my $self = shift();
$self->[SOCKET]->close();
$self->[LOG]->close() if $self->[CLOSELOG];
return $self->[SOCKET];
}
sub opened {
our $SOCKET;
local *SOCKET = $_[SOCKET] or return;
$SOCKET->opened();
}
use Data::Dumper;
sub stop_logging {
my $self = tied(${$_[0]});
#print "stop_logging( ".$self." )\n";
return if $self->[OFF];
$self->[OFF] = 1;
my $text = join(($\ || ''), $_[1])
or return;
$text .= "\x0D\x0A";
$text =~ s/\x0D\x0A(?=.)/\x0D\x0A<< /g;
$text = "<< ".$text if $self->[ENDLINE];
$self->[ENDLINE] = ($text =~ /\x0D\x0A$/);
$self->[LOG]->print($text);
}
sub start_logging {
my $self = tied(${$_[0]});
$self->[OFF] = 0;
}
*END*
my $pseudo_handle_code = <<'*END*';
package Mail::Sender::IO;
use IO::Handle;
use Tie::Handle;
@Mail::Sender::IO::ISA = qw(Tie::Handle);
sub TIEHANDLE {
my ($pkg,$sender) = @_;
return bless [$sender, $sender->{'_part'}], $pkg;
}
sub PRINT {
my $self = shift;
$self->[0]->SendEnc(@_);
}
sub PRINTF {
my $self = shift;
my $format = shift;
$self->[0]->SendEnc( sprintf $format, @_);
}
sub CLOSE {
my $self = shift();
if ($self->[1]) {
$self->[1]->EndPart();
} else {
$self->[0]->Close();
}
}
*END*
=head2 GetHandle
Returns a "filehandle" to which you can print the message or file to attach or whatever.
The data you print to this handle will be encoded as necessary. Closing this handle closes
either the message (for single part messages) or the part.
$sender->Open({...});
my $handle = $sender->GetHandle();
print $handle "Hello world.\n"
my ($mday,$mon,$year) = (localtime())[3,4,5];
printf $handle "Today is %04d/%02d/%02d.", $year+1900, $mon+1, $mday;
close $handle;
P.S.: There is a big difference between the handle stored in $sender->{'socket'} and the handle
returned by this function ! If you print something to $sender->{'socket'} it will be sent to the server
without any modifications, encoding, escaping, ...
You should NOT touch the $sender->{'socket'} unless you really really know what you are doing.
=cut
package Mail::Sender;
sub GetHandle {
my $self = shift();
unless (@Mail::Sender::IO::ISA) {
eval "use Symbol;";
eval $pseudo_handle_code;
}
my $handle = gensym();
tie *$handle, 'Mail::Sender::IO', $self;
return $handle;
}
=head1 FUNCTIONS
=head2 GuessCType
$ctype = GuessCType $filename, $filepath;
Guesses the content type based on the filename or the file contents.
This function is used when you attach a file and do not specify the content type.
It is not exported by default!
The builtin version uses the filename extension to guess the type.
Currently there are only a few extensions defined, you may add other extensions this way:
$Mail::Sender::CTypes{'EXT'} = 'content/type';
...
The extension has to be in UPPERCASE and will be matched case sensitively.
The package now includes three addins improving the guesswork. If you "use" one of them in your script,
it replaces the builtin GuessCType() subroutine with a better one:
Mail::Sender::CType::Win32
Win32 only, the content type is read from the registry
Mail::Sender::CType::Ext
any OS, a longer list of extensions from A. Guillaume
Mail::Sender::CType::LWP
any OS, uses LWP::MediaTypes::guess_media_type
=head2 ResetGMTdiff
ResetGMTdiff()
The module computes the local vs. GMT time difference to include in the timestamps
added into the message headers. As the time difference may change due to summer
savings time changes you may want to reset the time difference ocassionaly
in long running programs.
=head1 CONFIG
If you create a file named Sender.config in the same directory where
Sender.pm resides, this file will be "require"d as soon as you "use
Mail::Sender" in your script. Of course the Sender.config MUST "return a
true value", that is it has to be succesfully compiled and the last
statement must return a true value. You may use this to forbide the use
of Mail::Sender to some users.
You may define the default settings for new Mail::Sender objects and do
a few more things.
The default options are stored in hash %Mail::Sender::default. You may
use all the options you'd use in C<new>, C<Open>, C<OpenMultipart>,
C<MailMsg> or C<MailFile>.
Eg.
%default = (
smtp => 'mail.yourhost.cz',
from => getlogin.'yourhost.cz',
client => getlogin.'.yourhost.cz'
);
# of course you will use your own mail server here !
The other options you may set here (or later of course) are
$Mail::Sender::SITE_HEADERS, $Mail::Sender::NO_X_MAILER and
$Mail::Sender::NO_DATE. (These are plain old scalar variables, there is no
function or method for modifying them. Just set them to anything you need.)
The $Mail::Sender::SITE_HEADERS may contain headers that will be added
to each mail message sent by this script, the $Mail::Sender::NO_X_MAILER
disables the header item specifying that the message was sent by
Mail::Sender and $Mail::Sender::NO_DATE turns off the Date: header generation.
!!! $Mail::Sender::SITE_HEADERS may NEVER end with \r\n !!!
If you want to set the $Mail::Sender::SITE_HEADERS for every script sent
from your server without your users being able to change it you may use
this hack:
$loginname = something_that_identifies_the_user();
*Mail::Sender::SITE_HEADERS = \"X-Sender: $loginname via $0";
$Mail::Sender::NO_X_MAILER = 1;
You may even "install" your custom function that will be evaluated for
each message just before contacting the server. You may change all the
options from within as well as stop sending the message.
All you have to do is to create a function named SiteHook in
Mail::Sender package. This function will get the Mail::Sender object as
its first argument. If it returns a TRUE value the message is sent,
if it returns FALSE the sending is canceled and the user gets
"Site specific error" error message.
If you want to give some better error message you may do it like this :
sub SiteHook {
my $self = shift;
if (whatever($self)) {
$self->Error( SITEERROR);
$Mail::Sender::Error = "I don't like this mail";
return 0
} else {
return 1;
}
}
This example will ensure the from address is the users real address :
sub SiteHook {
my $self = shift;
$self->{'fromaddr'} = getlogin.'@yoursite.com';
$self->{'from'} = getlogin.'@yoursite.com';
1;
}
Please note that at this stage the from address is in two different
object properties.
$self->{'from'} is the address as it will appear in the mail, that is
it may include the full name of the user or any other comment
( "Jan Krynicky <jenda@krynicky.cz>" for example), while the
$self->{'fromaddr'} is realy just the email address per se and it will
be used in conversation with the SMTP server. It must be without
comments ("jenda@krynicky.cz" for example)!
Without write access to .../lib/Mail/Sender.pm or
.../lib/Mail/Sender.config your users will then be unable to get rid of
this header. Well ... everything is doable, if they are cheeky enough ... :-(
So if you take care of some site with virtual servers for several
clients and implement some policy via SiteHook() or
$Mail::Sender::SITE_HEADERS search the clients' scripts for "SiteHook"
and "SITE_HEADERS" from time to time. To see who's cheating.
=head1 AUTHENTICATION
If you get a "Local user "xxx@yyy.com" unknown on host "zzz"" message it usually means that
your mail server is set up to forbid mail relay. That is it only accepts messages to or from a local user.
If you need to be able to send a message with both the sender's and recipient's address remote, you
need to somehow authenticate to the server. You may need the help of the mail server's administrator
to find out what username and password and/or what authentication protocol are you supposed to use.
There are many authentication protocols defined for ESTMP, Mail::Sender natively supports
only PLAIN, LOGIN, CRAM-MD5 and NTLM (please see the docs for C<new Mail::Sender>).
If you want to know what protocols are supported by your server you may get the list by this:
/tmp# perl -MMail::Sender -e 'Mail::Sender->printAuthProtocols("the.server.com")'
or
c:\> perl -MMail::Sender -e "Mail::Sender->printAuthProtocols('the.server.com')"
There is one more way to authenticate. Some servers want you to login by POP3 before you
can send a message. You have to use Net::POP3 or Mail::POP3Client to do this.
=head2 Other protocols
It is possible to add new authentication protocols to Mail::Sender. All you have to do is
to define a function Mail::Sender::Auth::PROTOCOL_NAME that will implement
the login. The function gets one parameter ... the Mail::Sender object.
It can access these properties:
$obj->{'socket'} : the socket to print to and read from
you may use the send_cmd() function to send a request
and read a response from the server
$obj->{'authid'} : the username specified in the new Mail::Sender,
Open or OpenMultipart call
$obj->{'authpwd'} : the password
$obj->{auth...} : all unknown parameters passed to the constructor or the mail
opening/creation methods are preserved in the object. If the protocol requires
any other options, please use names starting with "auth". Eg. "authdomain", ...
$obj->{'error'} : this should be set to a negative error number. Please use numbers
below -1000 for custom errors.
$obj->{'error_msg'} : this should be set to the error message
If the login fails you should
1) Set $Mail::Sender::Error to the error message
2) Set $obj->{'error_msg'} to the error message
2) Set $obj->{'error'} to a negative number
3) return a negative number
If it succeeds, please return "nothing" :
return;
Please use the protocols defined within Sender.pm as examples.
=head1 EXAMPLES
=head2 Object creation
ref ($sender = new Mail::Sender { from => 'somebody@somewhere.com',
smtp => 'mail.yourISP.com', boundary => 'This-is-a-mail-boundary-435427'})
or die "Error in mailing : $Mail::Sender::Error\n";
or
my $sender = new Mail::Sender { ... };
die "Error in mailing : $Mail::Sender::Error\n" unless ref $sender;
or
my $sender = new Mail::Sender { ..., on_errors => 'undef' }
or die "Error in mailing : $Mail::Sender::Error\n";
You may specify the options either when creating the Mail::Sender object
or later when you open a message. You may also set the default options when
installing the module (See C<CONFIG> section). This way the admin may set
the SMTP server and even the authentication options and the users do not have
to specify it again.
You should keep in mind that the way Mail::Sender reports failures depends on the 'on_errors'=>
option. If you set it to 'die' it throws an exception, if you set it to C<undef> or C<'undef'> it returns
undef and otherwise it returns a negative error code!
=head2 Simple single part message
$sender = new Mail::Sender {
smtp => 'mail.yourISP.com',
from => 'somebody@somewhere.com',
on_errors => undef,
}
or die "Can't create the Mail::Sender object: $Mail::Sender::Error\n";
$sender->Open({
to => 'mama@home.org, papa@work.com',
cc => 'somebody@somewhere.com',
subject => 'Sorry, I\'ll come later.'
})
or die "Can't open the message: $sender->{'error_msg'}\n";
$sender->SendLineEnc("I'm sorry, but thanks to the lusers,
I'll come at 10pm at best.");
$sender->SendLineEnc("\nHi, Jenda");
$sender->Close()
or die "Failed to send the message: $sender->{'error_msg'}\n";
or
eval {
$sender = new Mail::Sender {
smtp => 'mail.yourISP.com',
from => 'somebody@somewhere.com',
on_errors => 'die',
};
$sender->Open({
to => 'mama@home.org, papa@work.com',
cc => 'somebody@somewhere.com',
subject => 'Sorry, I\'ll come later.'
});
$sender->SendLineEnc("I'm sorry, but thanks to the lusers,
I'll come at 10pm at best.");
$sender->SendLineEnc("\nHi, Jenda");
$sender->Close();
};
if ($@) {
die "Failed to send the message: $@\n";
}
or
$sender = new Mail::Sender {
smtp => 'mail.yourISP.com',
from => 'somebody@somewhere.com',
on_errors => 'code',
};
die "Can't create the Mail::Sender object: $Mail::Sender::Error\n"
unless ref $sender;
ref $sender->Open({
to => 'mama@home.org, papa@work.com',
cc => 'somebody@somewhere.com',
subject => 'Sorry, I\'ll come later.'
})
or die "Can't open the message: $sender->{'error_msg'}\n";
$sender->SendLineEnc("I'm sorry, but thanks to the lusers,
I'll come at 10pm at best.");
$sender->SendLineEnc("\nHi, Jenda");
ref $sender->Close
or die "Failed to send the message: $sender->{'error_msg'}\n";
=head2 Using GetHandle()
ref $sender->Open({to => 'friend@other.com', subject => 'Hello dear friend'})
or die "Error: $Mail::Sender::Error\n";
my $FH = $sender->GetHandle();
print $FH "How are you?\n\n";
print $FH <<'*END*';
I've found these jokes.
Doctor, I feel like a pack of cards.
Sit down and I'll deal with you later.
Doctor, I keep thinking I'm a dustbin.
Don't talk rubbish.
Hope you like'em. Jenda
*END*
$sender->Close;
# or
# close $FH;
or
eval {
$sender->Open({ on_errors => 'die',
to => 'mama@home.org, papa@work.com',
cc => 'somebody@somewhere.com',
subject => 'Sorry, I\'ll come later.'});
$sender->SendLineEnc("I'm sorry, but due to a big load of work,
I'll come at 10pm at best.");
$sender->SendLineEnc("\nHi, Jenda");
$sender->Close;
};
if ($@) {
print "Error sending the email: $@\n";
} else {
print "The mail was sent.\n";
}
=head2 Multipart message with attachment
$sender->OpenMultipart({to => 'Perl-Win32-Users@activeware.foo',
subject => 'Mail::Sender.pm - new module'});
$sender->Body;
$sender->SendEnc(<<'*END*');
Here is a new module Mail::Sender.
It provides an object based interface to sending SMTP mails.
It uses a direct socket connection, so it doesn't need any
additional program.
Enjoy, Jenda
*END*
$sender->Attach(
{description => 'Perl module Mail::Sender.pm',
ctype => 'application/x-zip-encoded',
encoding => 'Base64',
disposition => 'attachment; filename="Sender.zip"; type="ZIP archive"',
file => 'sender.zip'
});
$sender->Close;
or
$sender->OpenMultipart({to => 'Perl-Win32-Users@activeware.foo',
subject => 'Mail::Sender.pm - new version'});
$sender->Body({ msg => <<'*END*' });
Here is a new module Mail::Sender.
It provides an object based interface to sending SMTP mails.
It uses a direct socket connection, so it doesn't need any
additional program.
Enjoy, Jenda
*END*
$sender->Attach(
{description => 'Perl module Mail::Sender.pm',
ctype => 'application/x-zip-encoded',
encoding => 'Base64',
disposition => 'attachment; filename="Sender.zip"; type="ZIP archive"',
file => 'sender.zip'
});
$sender->Close;
or (in case you have the file contents in a scalar)
$sender->OpenMultipart({to => 'Perl-Win32-Users@activeware.foo',
subject => 'Mail::Sender.pm - new version'});
$sender->Body({ msg => <<'*END*' });
Here is a new module Mail::Sender.
It provides an object based interface to sending SMTP mails.
It uses a direct socket connection, so it doesn't need any
additional program.
Enjoy, Jenda
*END*
$sender->Part(
{description => 'Perl module Mail::Sender.pm',
ctype => 'application/x-zip-encoded',
encoding => 'Base64',
disposition => 'attachment; filename="Sender.zip"; type="ZIP archive"',
msg => $sender_zip_contents,
});
$sender->Close;
=head2 Using exceptions (no need to test return values after each function)
use Mail::Sender;
eval {
(new Mail::Sender {on_errors => 'die'})
->OpenMultipart({smtp=> 'jenda.krynicky.cz', to => 'jenda@krynicky.cz',subject => 'Mail::Sender.pm - new version'})
->Body({ msg => <<'*END*' })
Here is a new module Mail::Sender.
It provides an object based interface to sending SMTP mails.
It uses a direct socket connection, so it doesn't need any
additional program.
Enjoy, Jenda
*END*
->Attach({
description => 'Perl module Mail::Sender.pm',
ctype => 'application/x-zip-encoded',
encoding => 'Base64',
disposition => 'attachment; filename="Sender.zip"; type="ZIP archive"',
file => 'W:\jenda\packages\Mail\Sender\Mail-Sender-0.7.14.3.tar.gz'
})
->Close();
} or print "Error sending mail: $@\n";
=head2 Using MailMsg() shortcut to send simple messages
If everything you need is to send a simple message you may use:
if (ref ($sender->MailMsg({to =>'Jenda@Krynicky.czX', subject => 'this is a test',
msg => "Hi Johnie.\nHow are you?"}))) {
print "Mail sent OK."
} else {
die "$Mail::Sender::Error\n";
}
or
if ($sender->MailMsg({
smtp => 'mail.yourISP.com',
from => 'somebody@somewhere.com',
to =>'Jenda@Krynicky.czX',
subject => 'this is a test',
msg => "Hi Johnie.\nHow are you?"
}) < 0) {
die "$Mail::Sender::Error\n";
}
print "Mail sent OK."
=head2 Using MailMsg and authentication
if ($sender->MailMsg({
smtp => 'mail.yourISP.com',
from => 'somebody@somewhere.com',
to =>'Jenda@Krynicky.czX',
subject => 'this is a test',
msg => "Hi Johnie.\nHow are you?"
auth => 'NTLM',
authid => 'jenda',
authpwd => 'benda',
}) < 0) {
die "$Mail::Sender::Error\n";
}
print "Mail sent OK."
=head2 Using MailFile() shortcut to send an attachment
If you want to attach some files:
(ref ($sender->MailFile(
{to =>'you@address.com', subject => 'this is a test',
msg => "Hi Johnie.\nI'm sending you the pictures you wanted.",
file => 'image1.jpg,image2.jpg'
}))
and print "Mail sent OK."
)
or die "$Mail::Sender::Error\n";
=head2 Sending HTML messages
If you are sure the HTML doesn't contain any accentuated characters (with codes above 127).
open IN, $htmlfile or die "Cannot open $htmlfile : $!\n";
$sender->Open({ from => 'your@address.com', to => 'other@address.com',
subject => 'HTML test',
ctype => "text/html",
encoding => "7bit"
}) or die $Mail::Sender::Error,"\n";
while (<IN>) { $sender->SendEx($_) };
close IN;
$sender->Close();
Otherwise use SendEnc() instead of SendEx() and "quoted-printable" instead of "7bit".
Another ... quicker way ... would be:
open IN, $htmlfile or die "Cannot open $htmlfile : $!\n";
$sender->Open({ from => 'your@address.com', to => 'other@address.com',
subject => 'HTML test',
ctype => "text/html",
encoding => "quoted-printable"
}) or die $Mail::Sender::Error,"\n";
while (read IN, $buff, 4096) { $sender->SendEnc($buff) };
close IN;
$sender->Close();
=head2 Sending HTML messages with inline images
if (ref $sender->OpenMultipart({
from => 'someone@somewhere.net', to => $recipients,
subject => 'Embedded Image Test',
boundary => 'boundary-test-1',
multipart => 'related'})) {
$sender->Attach(
{description => 'html body',
ctype => 'text/html; charset=us-ascii',
encoding => '7bit',
disposition => 'NONE',
file => 'test.html'
});
$sender->Attach({
description => 'ed\'s gif',
ctype => 'image/gif',
encoding => 'base64',
disposition => "inline; filename=\"apache_pb.gif\";\r\nContent-ID: <img1>",
file => 'apache_pb.gif'
});
$sender->Close() or die "Close failed! $Mail::Sender::Error\n";
} else {
die "Cannot send mail: $Mail::Sender::Error\n";
}
And in the HTML you'll have this :
... <IMG src="cid:img1"> ...
on the place where you want the inlined image.
Please keep in mind that the image name is unimportant, it's the Content-ID what counts!
# or using the eval{ $obj->Method()->Method()->...->Close()} trick ...
use Mail::Sender;
eval {
(new Mail::Sender)
->OpenMultipart({
to => 'someone@somewhere.com',
subject => 'Embedded Image Test',
boundary => 'boundary-test-1',
type => 'multipart/related'
})
->Attach({
description => 'html body',
ctype => 'text/html; charset=us-ascii',
encoding => '7bit',
disposition => 'NONE',
file => 'c:\temp\zk\HTMLTest.htm'
})
->Attach({
description => 'Test gif',
ctype => 'image/gif',
encoding => 'base64',
disposition => "inline; filename=\"test.gif\";\r\nContent-ID: <img1>",
file => 'test.gif'
})
->Close()
}
or die "Cannot send mail: $Mail::Sender::Error\n";
=head2 Sending message with plaintext and HTML alternatives
use Mail::Sender;
eval {
(new Mail::Sender)
->OpenMultipart({
to => 'someone@somewhere.com',
subject => 'Alternatives',
# debug => 'c:\temp\zkMailFlow.log',
multipart => 'mixed',
})
->Part({ctype => 'multipart/alternative'})
->Part({ ctype => 'text/plain', disposition => 'NONE', msg => <<'*END*' })
A long
mail
message.
*END*
->Part({ctype => 'text/html', disposition => 'NONE', msg => <<'*END*'})
<html><body><h1>A long</h1><p align=center>
mail
message.
</p></body></html>
*END*
->EndPart("multipart/alternative")
->Close();
} or print "Error sending mail: $Mail::Sender::Error\n";
=head2 Sending message with plaintext and HTML alternatives with inline images
use Mail::Sender;
eval {
(new Mail::Sender)
->OpenMultipart({
to => 'someone@somewhere.com',
subject => 'Alternatives with images',
# debug => 'c:\temp\zkMailFlow.log',
multipart => 'related',
})
->Part({ctype => 'multipart/alternative'})
->Part({ ctype => 'text/plain', disposition => 'NONE', msg => <<'*END*' })
A long
mail
message.
*END*
->Part({ctype => 'text/html', disposition => 'NONE', msg => <<'*END*'})
<html><body><h1>A long</h1><p align=center>
mail
message.
<img src="cid:img1">
</p></body></html>
*END*
->EndPart("multipart/alternative")
->Attach({
description => 'ed\'s jpg',
ctype => 'image/jpeg',
encoding => 'base64',
disposition => "inline; filename=\"0518m_b.jpg\";\r\nContent-ID: <img1>",
file => 'E:\pix\humor\0518m_b.jpg'
})
->Close();
} or print "Error sending mail: $Mail::Sender::Error\n";
Keep in mind please that different mail clients display messages differently. You may
need to try several ways to create messages so that they appear the way you need.
These two examples looked like I expected in Pegasus Email and MS Outlook.
If this doesn't work with your mail client, please let me know and we might find a way.
=head2 Sending a file that was just uploaded from an HTML form
use CGI;
use Mail::Sender;
$query = new CGI;
# uploading the file...
$filename = $query->param('mailformFile');
if ($filename ne ""){
$tmp_file = $query->tmpFileName($filename);
}
$sender = new Mail::Sender {from => 'script@krynicky.cz',smtp => 'mail.krynicky.czX'};
$sender->OpenMultipart({to=> 'jenda@krynicky.czX',subject=> 'test CGI attach'});
$sender->Body();
$sender->Send(<<"*END*");
This is just a test of mail with an uploaded file.
Jenda
*END*
$sender->Attach({
encoding => 'Base64',
description => $filename,
ctype => $query->uploadInfo($filename)->{'Content-Type'},
disposition => "attachment; filename = $filename",
file => $tmp_file
});
$sender->Close();
print "Content-Type: text/plain\n\nYes, it's sent\n\n";
=head2 Listing the authentication protocols supported by the server
use Mail::Sender;
my $sender = new Mail::Sender {smtp => 'localhost'};
die "Error: $Mail::Sender::Error\n" unless ref $sender;
print join(', ', $sender->QueryAuthProtocols()),"\n";
or (if you have Mail::Sender 0.8.05 or newer)
use Mail::Sender;
print join(', ', Mail::Sender->QueryAuthProtocols('localhost')),"\n";
or
use Mail::Sender;
print join(', ', Mail::Sender::QueryAuthProtocols('localhost')),"\n";
=head2 FAQ
=head3 Forwarding the messages created by Mail::Sender removes accents. Why?
The most likely colprit is missing or incorrect charset specified for the body or
a part of the email. You should add something like
charset => 'iso-8859-1',
encoding => 'quoted-printable',
to the parameters passed to Open(), OpenMultipart(), MailMsg(), Body() or Part() or
b_charset => 'iso-8859-1',
b_encoding => 'quoted-printable',
to the parameters for MailFile().
If you use a different charset ('iso-8859-2', 'win-1250', ...) you will of course need
to specify that charset. If you are not sure, try to send a mail with some other mail client
and then look at the message/part headers.
=head2 Sometimes there is an equals sign at the end of an attached file when
I open the email in Outlook. What's wrong?
Outlook is. It has (had) a bug in its quoted printable decoding routines.
This problem happens only in quoted-printable encoded parts on multipart messages.
And only if the data in that part do not end with a newline. (This is new in 0.8.08, in older versions
it happened in all QP encoded parts.)
The problem is that an equals sign at the end of a line in a quoted printable encoded text means
"ignore the newline". That is
fooo sdfg sdfg sdfh dfh =
dfsgdsfg
should be decoded as
fooo sdfg sdfg sdfh dfh dfsgdsfg
The problem is at the very end of a file. The part boundary (text separating different
parts of a multipart message) has to start on a new line, if the attached file ends by a newline everything is cool.
If it doesn't I need to add a newline and to denote that the newline is not part of the original file I add an equals:
dfgd dsfgh dfh dfh dfhdfhdfhdfgh
this is the last line.=
--message-boundary-146464--
Otherwise I'd add a newline at the end of the file.
If you do not care about the newline and want to be sure Outlook doesn't add the equals to the file add
bypass_outlook_bug => 1
parameter to C<new Mail::Sender> or C<Open>/C<OpenMultipart>.
=head2 WARNING
DO NOT mix Open(Multipart)|Send(Line)(Ex)|Close with MailMsg or MailFile.
Both Mail(Msg/File) close any Open-ed mail.
Do not try this:
$sender = new Mail::Sender ...;
$sender->OpenMultipart...;
$sender->Body;
$sender->Send("...");
$sender->MailFile({file => 'something.ext');
$sender->Close;
This WON'T work!!!
=head2 GOTCHAS
=head3 Local user "someone@somewhere.com" doesn't exist
"Thanks" to spammers mail servers usually do not allow just anyone to post a message through them.
Most often they require that either the sender or the recipient is local to the server
=head3 Mail::Sendmail works, Mail::Sender doesn't
If you are able to connect to the mail server and scripts using Mail::Sendmail work, but Mail::Sender fails with
"connect() failed", please review the settings in /etc/services. The port for SMTP should be 25.
=head3 $/ and $\
If you change the $/ ($RS, $INPUT_RECORD_SEPARATOR) or $\ ($ORS, $OUTPUT_RECORD_SEPARATOR)
or $, ($OFS, $OUTPUT_FIELD_SEPARATOR) Mail::Sender may stop working! Keep in mind that those variables are global
and therefore they change the behaviour of <> and print everywhere.
And since the SMTP is a plain text protocol if you change the notion of lines you can break it.
If you have to fiddle with $/, $\ or $, do it in the smallest possible block of code and local()ize the change!
open my $IN, '<', $filename or die "Can't open $filename: $!\n";
my $data = do {local $/; <$IN>};
close $IN;
=head1 BUGS
I'm sure there are many. Please let me know if you find any.
The problem with multiline responses from some SMTP servers (namely qmail) is solved. At last.
=head1 SEE ALSO
MIME::Lite, MIME::Entity, Mail::Sendmail, Mail::Mailer, ...
There are lots of mail related modules on CPAN, with different capabilities and interfaces. You
have to find the right one yourself :-)
=head1 DISCLAIMER
This module is based on SendMail.pm Version : 1.21 that appeared in
Perl-Win32-Users@activeware.com mailing list. I don't remember the name
of the poster and it's not mentioned in the script. Thank you mr. C<undef>.
=head1 AUTHOR
Jan Krynicky <Jenda@Krynicky.cz>
http://Jenda.Krynicky.cz
With help of Rodrigo Siqueira <rodrigo@insite.com.br>,
Ed McGuigan <itstech1@gate.net>,
John Sanche <john@quadrant.net>,
Brian Blakley <bblakley@mp5.net>,
and others.
=head1 COPYRIGHT
Copyright (c) 1997-2014 Jan Krynicky <Jenda@Krynicky.cz>. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
You are discouraged from using this module for sending SPAM! (see
http://spam.abuse.net/ for definition). It is unethical and, in many
jurisdictions, illegal.
=cut