497 lines
16 KiB
Perl
497 lines
16 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::Mail::Send
|
|
# Author : Scott Beck
|
|
# CVS Info : 087,071,086,086,085
|
|
# $Id: Send.pm,v 1.54 2007/08/01 23:35:16 brewt Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
|
|
package GT::Mail::Send;
|
|
|
|
use strict;
|
|
use GT::Base;
|
|
use GT::Socket::Client;
|
|
use GT::Mail::POP3;
|
|
use GT::MD5;
|
|
use vars qw(@ISA $VERSION $DEBUG $ATTRIBS $ERRORS $CRLF %SENDMAIL_ERRORS $HAVE_SSL);
|
|
|
|
%SENDMAIL_ERRORS = (
|
|
64 => 'EX_USAGE',
|
|
65 => 'EX_DATAERR',
|
|
66 => 'EX_NOINPUT',
|
|
67 => 'EX_NOUSER',
|
|
68 => 'EX_NOHOST',
|
|
69 => 'EX_UNAVAILABLE',
|
|
70 => 'EX_SOFTWARE',
|
|
71 => 'EX_OSERR',
|
|
72 => 'EX_OSFILE',
|
|
73 => 'EX_CANTCREAT',
|
|
74 => 'EX_IOERR',
|
|
75 => 'EX_TEMPFAIL',
|
|
76 => 'EX_PROTOCOL',
|
|
77 => 'EX_NOPERM',
|
|
78 => 'EX_CONFIG',
|
|
|
|
# This is for qmail-inject's version of sendmail
|
|
# Nice that they are different..
|
|
111 => 'EX_TEMPFAIL',
|
|
100 => 'EX_USAGE',
|
|
);
|
|
|
|
@ISA = qw/GT::Base/;
|
|
$VERSION = sprintf "%d.%03d", q$Revision: 1.54 $ =~ /(\d+)\.(\d+)/;
|
|
$DEBUG = 0;
|
|
$ATTRIBS = {
|
|
mail => undef,
|
|
host => undef,
|
|
port => undef,
|
|
ssl => undef,
|
|
from => undef,
|
|
path => undef,
|
|
flags => undef,
|
|
rcpt => undef,
|
|
user => undef,
|
|
pass => undef,
|
|
helo => undef,
|
|
pbs_user => undef,
|
|
pbs_pass => undef,
|
|
pbs_host => undef,
|
|
pbs_port => undef,
|
|
pbs_auth_mode => undef,
|
|
pbs_ssl => undef,
|
|
debug => 0,
|
|
};
|
|
$ERRORS = {
|
|
HOSTNOTFOUND => "SMTP: server '%s' was not found.",
|
|
CONNFAILED => "SMTP: connect() failed. reason: %s",
|
|
SERVNOTAVAIL => "SMTP: Service not available: %s",
|
|
SSLNOTAVAIL => "SMTP: SSL connections are not available: Net::SSLeay 1.06 or greater not installed.",
|
|
COMMERROR => "SMTP: Unspecified communications error: '%s'.",
|
|
USERUNKNOWN => "SMTP: Local user '%s' unknown on host '%s'. Server said: %s",
|
|
TRANSFAILED => "SMTP: Transmission of message failed: %s",
|
|
AUTHFAILED => "SMTP: Authentication failed: %s",
|
|
TOEMPTY => "No To: field specified.",
|
|
NOMSG => "No message body specified",
|
|
SENDMAILNOTFOUND => "Sendmail was not defined or not found: %s",
|
|
NOOPTIONS => "No options were specified. Be sure to pass a hash ref to send()",
|
|
NOTRANSPORT => "Neither sendmail nor SMTP were specified!",
|
|
SENDMAIL => "There was a problem sending to Sendmail: (%s)",
|
|
NOMAILOBJ => "No mail object was specified.",
|
|
EX_USAGE => "Command line usage error",
|
|
EX_DATAERR => "Data format error",
|
|
EX_NOINPUT => "Cannot open input",
|
|
EX_NOUSER => "Addressee unknown",
|
|
EX_NOHOST => "Host name unknown",
|
|
EX_UNAVAILABLE => "Service unavailable",
|
|
EX_SOFTWARE => "Internal software error",
|
|
EX_OSERR => "System error (e.g., can't fork)",
|
|
EX_OSFILE => "Critical OS file missing",
|
|
EX_CANTCREAT => "Can't create (user) output file",
|
|
EX_IOERR => "Input/output error",
|
|
EX_TEMPFAIL => "Temp failure; user is invited to retry",
|
|
EX_PROTOCOL => "Remote error in protocol",
|
|
EX_NOPERM => "Permission denied",
|
|
EX_CONFIG => "Configuration error",
|
|
EX_UNKNOWN => "Sendmail exited with an unknown exit status: %s"
|
|
};
|
|
$CRLF = "\015\012";
|
|
|
|
sub init {
|
|
my $self = shift;
|
|
$self->set(@_);
|
|
|
|
# We need either a host or a path to sendmail and an email object
|
|
$self->{host} or $self->{path} or return $self->error("NOTRANSPORT", "FATAL");
|
|
exists $self->{mail} or return $self->error("NOMAILOBJ", "FATAL");
|
|
|
|
# Set debugging
|
|
$self->{_debug} = defined($self->{debug}) ? $self->{debug} : $DEBUG;
|
|
|
|
# Default port for smtp
|
|
if ($self->{host} and !$self->{port}) {
|
|
$self->{port} = $self->{ssl} ? 465 : 25;
|
|
}
|
|
|
|
# Default flags for sendmail
|
|
elsif ($self->{path}) {
|
|
($self->{flags}) or $self->{flags} = '-t -oi -oeq';
|
|
$self->{path} =~ /^\s*(.+?)\s*$/ and $self->{path} = $1; # Untaint
|
|
(-e $self->{path}) or return $self->error('SENDMAILNOTFOUND', 'FATAL', $1);
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
sub smtp_send {
|
|
# ---------------------------------------------------------------
|
|
#
|
|
my ($self, $sock, $cmd) = @_;
|
|
|
|
if (defined $cmd) {
|
|
print $sock "$cmd$CRLF";
|
|
$self->debug("SMTP Log: >> $cmd\n") if $self->{debug} > 1;
|
|
}
|
|
|
|
$_ = <$sock>;
|
|
return if !$_;
|
|
|
|
my $resp = $_;
|
|
if (/^\d{3}-/) {
|
|
while (defined($_ = <$sock>) and /^\d{3}-/) {
|
|
$resp .= $_;
|
|
}
|
|
$resp .= $_;
|
|
}
|
|
$resp =~ s/$CRLF/\n/g;
|
|
$self->debug("SMTP Log: << $resp") if $self->{debug} > 1;
|
|
return $resp;
|
|
}
|
|
|
|
sub smtp {
|
|
# ---------------------------------------------------------------
|
|
# Opens a smtp port and sends the message headers.
|
|
#
|
|
my $self = shift;
|
|
|
|
ref $self or $self = $self->new(@_);
|
|
|
|
if ($self->{ssl}) {
|
|
$HAVE_SSL ||= eval { require Net::SSLeay; Net::SSLeay->require_version(1.06); 1 };
|
|
$HAVE_SSL or return $self->error('SSLNOTAVAIL', 'FATAL');
|
|
}
|
|
|
|
if ($self->{pbs_host}) {
|
|
my $pop = GT::Mail::POP3->new(
|
|
host => $self->{pbs_host},
|
|
port => $self->{pbs_port},
|
|
user => $self->{pbs_user},
|
|
pass => $self->{pbs_pass},
|
|
auth_mode => $self->{pbs_auth_mode},
|
|
ssl => $self->{pbs_ssl},
|
|
debug => $self->{debug}
|
|
);
|
|
my $count = $pop->connect();
|
|
if (!defined($count)) {
|
|
$self->debug("Couldn't connect to server for POP3 before SMTP authentication: $GT::Mail::POP3::error") if $self->{debug};
|
|
}
|
|
else {
|
|
$pop->quit();
|
|
}
|
|
}
|
|
|
|
my $sock = GT::Socket::Client->open(
|
|
host => $self->{host},
|
|
port => $self->{port},
|
|
ssl => $self->{ssl}
|
|
) or return $self->error("CONNFAILED", "WARN", GT::Socket::Client->error);
|
|
|
|
local $SIG{PIPE} = 'IGNORE';
|
|
local $_;
|
|
|
|
# Get the server's greeting message
|
|
my $resp = $self->smtp_send($sock) or return $self->error('COMMERROR', 'WARN');
|
|
return $self->error('SERVNOTAVAIL', 'WARN', $resp) if $resp =~ /^[45]/;
|
|
|
|
# Decide what hostname to use on the HELO/EHLO line
|
|
my $helo = $self->{helo};
|
|
$helo ||= $ENV{SERVER_NAME};
|
|
eval {
|
|
require Sys::Hostname;
|
|
$helo = Sys::Hostname::hostname();
|
|
} unless $helo;
|
|
$helo ||= $self->{host};
|
|
|
|
$resp = $self->smtp_send($sock, "EHLO $helo") or return $self->error('COMMERROR', 'WARN');
|
|
if ($resp =~ /^[45]/) {
|
|
$resp = $self->smtp_send($sock, "HELO $helo") or return $self->error('COMMERROR', 'WARN');
|
|
return $self->error('SERVNOTAVAIL', 'WARN', $resp) if $resp =~ /^[45]/;
|
|
}
|
|
|
|
# Authenticate if needed
|
|
if ($resp =~ /AUTH[ =](.*)/ and $self->{user}) {
|
|
my $server = uc $1;
|
|
my $method = '';
|
|
# These are the authentication types that are supported, ordered by preference
|
|
for my $m (qw/CRAM-MD5 PLAIN LOGIN/) {
|
|
if ($server =~ /$m/) {
|
|
$method = $m;
|
|
last;
|
|
}
|
|
}
|
|
if ($method eq 'CRAM-MD5') {
|
|
$resp = $self->smtp_send($sock, "AUTH CRAM-MD5") or return $self->error('COMMERROR', 'WARN');
|
|
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
|
|
|
my ($challenge) = $resp =~ /\d{3}\s+(.*)/;
|
|
$challenge = decode_base64($challenge);
|
|
my $auth = encode_base64("$self->{user} " . hmac_md5_hex($challenge, $self->{pass}));
|
|
|
|
$resp = $self->smtp_send($sock, $auth) or return $self->error('COMMERROR', 'WARN');
|
|
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
|
}
|
|
elsif ($method eq 'PLAIN') {
|
|
my $auth = encode_base64("$self->{user}\0$self->{user}\0$self->{pass}");
|
|
$resp = $self->smtp_send($sock, "AUTH PLAIN $auth") or return $self->error('COMMERROR', 'WARN');
|
|
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
|
}
|
|
elsif ($method eq 'LOGIN') {
|
|
$resp = $self->smtp_send($sock, "AUTH LOGIN") or return $self->error('COMMERROR', 'WARN');
|
|
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
|
|
|
$resp = $self->smtp_send($sock, encode_base64($self->{user})) or return $self->error('COMMERROR', 'WARN');
|
|
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
|
|
|
$resp = $self->smtp_send($sock, encode_base64($self->{pass})) or return $self->error('COMMERROR', 'WARN');
|
|
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
|
}
|
|
}
|
|
|
|
# We use return-path so the email will bounce to who it's from, not the user
|
|
# doing the sending.
|
|
my $from = $self->{mail}->{head}->get('return-path') || $self->{mail}->{head}->get('from');
|
|
$from = $self->extract_email($from) || '';
|
|
|
|
$self->debug("Sending from: <$from>") if $self->{debug} == 1;
|
|
$resp = $self->smtp_send($sock, "MAIL FROM: <$from>") or return $self->error('COMMERROR', 'WARN');
|
|
return $self->error('COMMERROR', 'WARN', $resp) if $resp =~ /^[45]/;
|
|
|
|
my $found_valid = 0;
|
|
my @tos = ($self->{mail}->{head}->split_field('to'), $self->{mail}->{head}->split_field('bcc'), $self->{mail}->{head}->split_field('cc'));
|
|
for my $to (@tos) {
|
|
next unless $to and my $email = $self->extract_email($to);
|
|
|
|
$found_valid++;
|
|
$self->debug("Sending RCPT TO: <$email>.") if $self->{debug} == 1;
|
|
$resp = $self->smtp_send($sock, "RCPT TO: <$email>") or return $self->error('COMMERROR', 'WARN');
|
|
return $self->error('USERUNKNOWN', 'WARN', $email, $self->{host}, $resp) if $resp =~ /^[45]/;
|
|
}
|
|
$found_valid or return $self->error('TOEMPTY', 'FATAL');
|
|
|
|
$resp = $self->smtp_send($sock, "DATA") or return $self->error('COMMERROR', 'WARN');
|
|
return $self->error('COMMERROR', 'WARN', $resp) if $resp =~ /^[45]/;
|
|
|
|
# Remove Bcc from the headers.
|
|
my @bcc = $self->{mail}->{head}->delete('bcc');
|
|
|
|
my $mail = $self->{mail}->to_string;
|
|
|
|
# SMTP needs any leading .'s to be doubled up.
|
|
$mail =~ s/^\./../gm;
|
|
|
|
# Print the mail body.
|
|
$resp = $self->smtp_send($sock, $mail . $CRLF . '.') or return $self->error('COMMERROR', 'WARN');
|
|
return $self->error('TRANSFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
|
|
|
# Add them back in.
|
|
foreach my $bcc (@bcc) {
|
|
$self->{mail}->{head}->set('bcc', $bcc);
|
|
}
|
|
|
|
# Close the connection.
|
|
$resp = $self->smtp_send($sock, "QUIT") or return $self->error('COMMERROR', 'WARN');
|
|
close $sock;
|
|
return 1;
|
|
}
|
|
|
|
sub sendmail {
|
|
# ---------------------------------------------------------------
|
|
# Sends a message using sendmail.
|
|
#
|
|
my $self = shift;
|
|
|
|
ref $self or $self = $self->new(@_);
|
|
|
|
# Get a filehandle, and open pipe to sendmail.
|
|
my $s = \do{ local *FH; *FH };
|
|
|
|
# If the email address is safe, we set the envelope via -f so bounces are handled properly.
|
|
my $from = $self->{mail}->{head}->get('return-path') || $self->{mail}->{head}->get('from');
|
|
my $envelope = '';
|
|
if ($from =~ /<?([\w\-\.]+\@[\w\-\.]+)>?/) {
|
|
$envelope = "-f $1";
|
|
}
|
|
elsif ($from eq '<>' or $from eq '') {
|
|
$envelope = "-f ''";
|
|
}
|
|
open($s, "|$self->{path} $self->{flags} $envelope 1>&2") or return $self->error("SENDMAIL", "WARN", "$!");
|
|
$self->{mail}->write($s);
|
|
return 1 if close $s;
|
|
my $exit_value = $? >> 8;
|
|
|
|
my $code;
|
|
if (exists $SENDMAIL_ERRORS{$exit_value}) {
|
|
$code = $SENDMAIL_ERRORS{$exit_value};
|
|
}
|
|
else {
|
|
$code = 'EX_UNKNOWN';
|
|
}
|
|
if ($code eq 'EX_TEMPFAIL') {
|
|
return 1;
|
|
}
|
|
return $self->error($code, "WARN", $exit_value);
|
|
return 1;
|
|
}
|
|
|
|
sub extract_email {
|
|
# -----------------------------------------------------------------------------
|
|
# Takes a field, returns the e-mail address contained in that field, or undef
|
|
# if no e-mail address could be found.
|
|
#
|
|
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
|
|
|
my $to = shift;
|
|
|
|
# We're trying to get down to the actual e-mail address. To do so, we have to
|
|
# remove quoted strings and comments, then extract the e-mail from whatever is
|
|
# left over.
|
|
$to =~ s/"(?:[^"\\]|\\.)*"//g;
|
|
1 while $to =~ s/\((?:[^()\\]|\\.)*\)//sg;
|
|
|
|
my ($email) = $to =~ /([^<>\s]+\@[\w.-]+)/;
|
|
|
|
return $email;
|
|
}
|
|
|
|
sub encode_base64 {
|
|
my $res = '';
|
|
pos($_[0]) = 0; # In case something has previously adjusted pos
|
|
while ($_[0] =~ /(.{1,45})/gs) {
|
|
$res .= substr(pack(u => $1), 1, -1);
|
|
}
|
|
$res =~ tr|` -_|AA-Za-z0-9+/|;
|
|
|
|
my $padding = (3 - length($_[0]) % 3) % 3;
|
|
$res =~ s/.{$padding}$/'=' x $padding/e if $padding;
|
|
$res;
|
|
}
|
|
|
|
sub decode_base64 {
|
|
my $str = shift;
|
|
my $res = '';
|
|
|
|
$str =~ tr|A-Za-z0-9+=/||cd;
|
|
|
|
$str =~ s/=+$//;
|
|
$str =~ tr|A-Za-z0-9+/| -_|;
|
|
return '' unless length $str;
|
|
|
|
my $uustr = '';
|
|
my ($i, $l);
|
|
$l = length($str) - 60;
|
|
for ($i = 0; $i <= $l; $i += 60) {
|
|
$uustr .= "M" . substr($str, $i, 60);
|
|
}
|
|
$str = substr($str, $i);
|
|
# and any leftover chars
|
|
if ($str ne "") {
|
|
$uustr .= chr(32 + length($str) * 3 / 4) . $str;
|
|
}
|
|
return unpack("u", $uustr);
|
|
}
|
|
|
|
sub hmac_md5_hex {
|
|
my ($challenge, $data) = @_;
|
|
|
|
GT::MD5::md5($challenge) if length $challenge > 64;
|
|
|
|
my $ipad = $data ^ (chr(0x36) x 64);
|
|
my $opad = $data ^ (chr(0x5c) x 64);
|
|
|
|
return GT::MD5::md5_hex($opad, GT::MD5::md5($ipad, $challenge));
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
GT::Mail::Send - Module to send emails
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use GT::Mail::Send;
|
|
|
|
# $mail_object must be a GT::Mail object
|
|
my $send = new GT::Mail::Send (
|
|
mail => $mail_object,
|
|
host => 'smtp.gossamer-threads.com',
|
|
debug => 1
|
|
);
|
|
|
|
$send->smtp or die $GT::Mail::Send::error;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
GT::Mail::Send is an object interface to sending email over either
|
|
SMTP or Sendmail. This module is used internally to GT::Mail.
|
|
|
|
=head2 new - Constructor method
|
|
|
|
Returns a new GT::Mail::Send object. You must specify either the smtp host
|
|
or a path to sendmail. This method is inherented from GT::Base. The arguments
|
|
can be in the form of a hash or hash ref.
|
|
|
|
=over 4
|
|
|
|
=item debug
|
|
|
|
Sets the debug level for this instance of GT::Mail::Send.
|
|
|
|
=item mail
|
|
|
|
Specify the mail object to use. This must be a GT::Mail object and must contain
|
|
an email, either passed in or parsed in.
|
|
|
|
=item host
|
|
|
|
Specify the host to use when sending by SMTP.
|
|
|
|
=item port
|
|
|
|
Specify the port to use when sending over SMTP. Defaults to 25.
|
|
|
|
=item helo
|
|
|
|
The hostname to output on the HELO/EHLO line on an SMTP connection. Defaults to
|
|
$ENV{SERVER_NAME} or the system hostname (if Sys::Hostname is available).
|
|
|
|
=item path
|
|
|
|
Specify the path to sendmail when sending over sendmail. If the binary passed in
|
|
does not exist, undef will be returned and the error set in GT::Mail::Send::error.
|
|
|
|
=item flags
|
|
|
|
Specify the flags used to call sendmail. Defaults to -t -oi -oeq, see the Sendmail
|
|
guilde for sendmail for more info on the parameters to sendmail.
|
|
|
|
=back
|
|
|
|
=head2 smtp
|
|
|
|
Class or instance method. Sends the passed in email over SMTP. If called as a class
|
|
method, the parameters passed in will be used to call new(). Returns true on error,
|
|
false otherwise.
|
|
|
|
=head2 sendmail
|
|
|
|
Class or instance method. Send the passed in email to sendmail using the specified
|
|
path and flags. If called as a class method all additional arguments are passed to the
|
|
new() method. Returns true on success and false otherwise.
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
http://www.gossamer-threads.com/
|
|
|
|
=head1 VERSION
|
|
|
|
Revision: $Id: Send.pm,v 1.54 2007/08/01 23:35:16 brewt Exp $
|
|
|
|
=cut
|
|
|
|
|