# ================================================================== # 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 =~ /?/) { $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