diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Net/SMTP/TLS.pm')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Net/SMTP/TLS.pm | 401 |
1 files changed, 401 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Net/SMTP/TLS.pm b/Master/tlpkg/tlperl/lib/Net/SMTP/TLS.pm new file mode 100755 index 00000000000..10f9f196e40 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Net/SMTP/TLS.pm @@ -0,0 +1,401 @@ +=head1 NAME + +Net::SMTP::TLS - An SMTP client supporting TLS and AUTH + +=head1 VERSION + +Version 0.12 + +=head1 SYNOPSIS + + use Net::SMTP::TLS; + my $mailer = new Net::SMTP::TLS( + 'your.mail.host', + Hello => 'some.host.name', + Port => 25, #redundant + User => 'emailguy', + Password=> 's3cr3t'); + $mailer->mail('emailguy@your.mail.host'); + $mailer->to('someonecool@somewhere.else'); + $mailer->data; + $mailer->datasend("Sent thru TLS!"); + $mailer->dataend; + $mailer->quit; + +=head1 DESCRIPTION + +B<Net::SMTP::TLS> is a TLS and AUTH capable SMTP client which offers an interface that users will find familiar from L<Net::SMTP>. B<Net::SMTP::TLS> implements a subset of the methods provided by that module, but certainly not (yet) a complete mirror image of that API. + +The methods supported by B<Net::SMTP::TLS> are used in the above example. Though self explanatory for the most part, please see the perldoc for L<Net::SMTP> if you are unclear. + +The differences in the methods provided are as follows: + +=over + +The I<mail> method does not take the options list taken by L<Net::SMTP> + +The I<to> method also does not take options, and is the only method available to set the recipient (unlike the many synonyms provided by L<Net::SMTP>). + +The constructor takes a limited number of L<Net::SMTP>'s parameters. The constructor for B<Net::SMTP::TLS> takes the following (in addition to the hostname of the mail server, which must be the first parameter and is not explicitly named): + +=over + +NoTLS - In the unlikely event that you need to use this class to perform non-TLS SMTP (you ought to be using Net::SMTP itself for that...), this will turn off TLS when supplied with a true value. This will most often cause an error related to authentication when used on a server that requires TLS + +Hello - hostname used in the EHLO command + +Port - port to connect to the SMTP service (defaults to 25) + +Timeout - Timeout for inital socket connection (defaults to 5, passed directly to L<IO::Socket::INET>) + +User - username for SMTP AUTH + +Password - password for SMTP AUTH + +=back + +=back + +=head1 TLS and AUTHentication + +During construction of an B<Net::SMTP::TLS> instance, the full login process will occur. This involves first sending EHLO to the server, then initiating a TLS session through STARTTLS. Once this is complete, the module will attempt to login using the credentials supplied by the constructor, if such credentials have been supplied. + +The AUTH method will depend on the features returned by the server after the EHLO command. Based on that, CRAM-MD5 will be used if available, followed by LOGIN, followed by PLAIN. Please note that LOGIN is the only method of authentication that has been tested. CRAM-MD5 and PLAIN login functionality was taken directly from the script mentioned in the acknowledgements section, however, I have not tested them personally. + +=head1 ERROR HANDLING + +This module will croak in the event of an SMTP error. Should you wish to handle this gracefully in your application, you may wrap your mail transmission in an eval {} block and check $@ afterward. + +=head1 ACKNOWLEDGEMENTS + +This code was blatantly plagiarized from Michal Ludvig's smtp-client.pl script. See L<http://www.logix.cz/michal/devel/smtp> for his excellent work. + +=head1 AUTHOR + +Alexander Christian Westholm, awestholm at verizon dawt net + +Improvements courtesy of Tomek Zielinski + +=cut + +package Net::SMTP::TLS; + +use strict; +use warnings; + +our $VERSION = '0.12'; +use Carp; + +use Net::SSLeay; +use IO::Socket::INET; +use IO::Socket::SSL; +use MIME::Base64 qw[encode_base64 decode_base64]; +use Digest::HMAC_MD5 qw[hmac_md5_hex]; + +BEGIN { #set up Net::SSLeay's internals + Net::SSLeay::load_error_strings(); + Net::SSLeay::SSLeay_add_ssl_algorithms(); + Net::SSLeay::randomize(); +} + +sub new { + my $pkg = shift; + my $host= shift; + my %args= @_; + $args{Host} = $host; + $args{Hello}= "localhost" if not $args{Hello}; + # make the non-SSL socket that will later be + # transformed + $args{sock} = new IO::Socket::INET( + PeerAddr => $host, + PeerPort => $args{Port} || 25, + Proto => 'tcp', + Timeout => $args{Timeout} || 5) + or croak "Connect failed :$@\n"; + + my $me = bless \%args, $pkg; + # read the line immediately after connecting + my ($rsp,$txt) = $me->_response(); + if(not $rsp == 220){ + croak "Could not connect to SMTP server: $host $txt\n"; + } + $me->hello(); # the first hello, 2nd after starttls + $me->starttls() if not $args{NoTLS}; # why we're here, after all + $me->login() if($me->{User} and $me->{Password}); + return $me; +} + +# simply print a command to the server +sub _command { + my $me = shift; + my $command = shift; + $me->{sock}->printf($command."\015\012"); +} + +# read a line from the server and parse the +# CODE SEPERATOR TEXT response format +sub _response { + my $me = shift; + my $line = $me->{sock}->getline(); + my @rsp = ($line =~ /(\d+)(.)([^\r]*)/); + # reverse things so the seperator is at the end... + # that way we don't have to get fancy with the return + # values for calls that don't require the "more indicator" + return ($rsp[0],$rsp[2],$rsp[1]); +} + +# issue an EHLO command using the hostname provided to the constructor via +# the Hello paramter, which defaults to localhost. After that, read +# all the ESMTP capabilities returned by the server +sub hello { + my $me = shift; + $me->_command("EHLO ".$me->{Hello}); + my ($num,$txt,$more) = $me->_response(); + if(not $num == 250){ + croak "EHLO command failed: $num $txt\n"; + } + my %features = (); + # SMTP uses the dash to seperate the status code from + # the response text while there are more lines remaining + while($more eq '-'){ + ($num,$txt,$more) = $me->_response(); + $txt =~ s/[\n|\r]//g; + $txt =~ /(\S+)\s(.*)$/; + my ($feat, $parm) = ($txt =~ /^(\w+)[= ]*(.*)$/); + $features{$feat} = $parm; + } + $me->{features} = \%features; + return 1; +} + +# the magic! issue the STARTTLS command and +# use IO::Socket::SSL to transform that no-good +# plain old socket into an SSL socket +sub starttls { + my $me = shift; + $me->_command("STARTTLS"); + my ($num,$txt) = $me->_response(); + if(not $num == 220){ + croak "Invalid response for STARTTLS: $num $txt\n"; + } + if(not IO::Socket::SSL::socket_to_SSL($me->{sock}, + SSL_version => "SSLv3 TLSv1")){ + croak "Couldn't start TLS: ".IO::Socket::SSL::errstr."\n"; + } + $me->hello(); +} + +# based on the AUTH line returned in the features after EHLO, +# determine which type of authentication to perform +sub login { + my $me = shift; + my $type= $me->{features}->{AUTH}; + if(not $type){ + croak "Server did not return AUTH in capabilities\n"; + } + if($type =~ /CRAM\-MD5/){ + $me->auth_MD5(); + }elsif($type =~ /LOGIN/){ + $me->auth_LOGIN(); + }elsif($type =~ /PLAIN/){ + $me->auth_PLAIN(); + }else{ + croak "Unsupported Authentication mechanism\n"; + } +} + +# perform a LOGIN authentication... +# works well on my box. +sub auth_LOGIN { + my $me = shift; + $me->_command("AUTH LOGIN"); + my ($num,$txt) = $me->_response(); + if(not $num == 334){ + croak "Cannot authenticate via LOGIN: $num $txt\n"; + } + $me->_command(encode_base64($me->{User},"")); + ($num,$txt) = $me->_response(); + if(not $num == 334){ + croak "Auth failed: $num $txt\n"; + } + $me->_command(encode_base64($me->{Password},"")); + ($num,$txt) = $me->_response(); + if(not $num == 235){ + croak "Auth failed: $num $txt\n"; + } +} + +# use MD5 to login... gets the ticket from the text +# of the line returned after the auth command is issued. +# NOTE: untested +sub auth_MD5{ + my $me =shift; + $me->_command("AUTH CRAM-MD5"); + my ($num,$txt) = $me->_response(); + if(not $num == 334){ + croak "Cannot authenticate via CRAM-MD5: $num $txt\n"; + } + my $ticket = decode_base64($txt) or + croak "Unable to decode ticket"; + my $md5_pass = hmac_md5_hex($ticket, $me->{Password}); + $me->_command(encode_base64( + $me->{User}." ".$md5_pass, "")); + ($num,$txt) = $me->_response(); + if(not $num == 235){ + croak "Auth failed: $num $txt\n"; + } +} + +# perform plain authentication +sub auth_PLAIN{ + my $me = shift; + my $user= $me->{User}; + my $pass= $me->{Password}; + $me->_command(sprintf("AUTH PLAIN %S", + encode_base64("$user\0$user\0$pass",""))); + my ($num,$txt) = $me->_response(); + if(not $num == 235){ + croak "Auth failed: $num $txt\n"; + } +} + +sub _addr { + my $addr = shift; + $addr = "" unless defined $addr; + + return $1 if $addr =~ /(<[^>]*>)/; + $addr =~ s/^\s+|\s+$//sg; + + "<$addr>"; +} + +# send the MAIL FROM: <addr> command +sub mail { + my $me = shift; + my $from= shift; + $me->_command("MAIL FROM: "._addr($from)); + my ($num,$txt) = $me->_response(); + if(not $num == 250){ + croak "Could't set FROM: $num $txt\n"; + } +} + +# send the RCPT TO: <addr> command +sub recipient +{ + my $me = shift; + + + my $addr; + foreach $addr (@_) + { + $me->_command("RCPT TO: "._addr($addr)); + my ($num,$txt) = $me->_response(); + if(not $num == 250){ + croak "Couldn't send TO <$addr>: $num $txt\n"; + } + } +} + +BEGIN { + *to = \&recipient; + *cc = \&recipient; + *bcc = \&recipient; +} + + +# start the body of the message +# I would probably have designed the public methods of +# this class differently, but this is to keep with +# Net::SMTP's API +sub data { + my $me = shift; + $me->_command("DATA"); + my ($num,$txt) = $me->_response(); + if(not $num == 354){ + croak "Data failed: $num $txt\n"; + } +} + +# send stuff over raw (for use as message body) +sub datasend { + my $cmd = shift; + my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; + my $line = join("" ,@$arr); + + return 0 unless defined(fileno($cmd->{sock})); + + my $last_ch = $cmd->{last_ch}; + $last_ch = $cmd->{last_ch} = "\012" unless defined $last_ch; + + return 1 unless length $line; + + $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015"; + + my $first_ch = ''; + + if ($last_ch eq "\015") { + $first_ch = "\012" if $line =~ s/^\012//; + } + elsif ($last_ch eq "\012") { + $first_ch = "." if $line =~ /^\./; + } + + $line =~ s/\015?\012(\.?)/\015\012$1$1/sg; + + substr($line,0,0) = $first_ch; + + $cmd->{last_ch} = substr($line,-1,1); + + my $len = length($line); + my $offset = 0; + my $win = ""; + vec($win,fileno($cmd->{sock}),1) = 1; + my $timeout = $cmd->{sock}->timeout || undef; + + local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS'; + + while($len) + { + my $wout; + if (select(undef,$wout=$win, undef, $timeout) > 0 or -f $cmd->{sock}) # -f for testing on win32 + { + my $w = syswrite($cmd->{sock}, $line, $len, $offset); + unless (defined($w)) + { + carp("Error: $!"); + return undef; + } + $len -= $w; + } + else + { + carp("Error: Timeout"); + return undef; + } + } + +} + +# end the message body submission by a line with nothing +# but a period on it. +sub dataend { + my $me = shift; + $me->_command("\015\012."); + my ($num,$txt) = $me->_response(); + if(not $num == 250){ + croak "Couldn't send mail: $num $txt\n"; + } +} + +# politely disconnect from the SMTP server. +sub quit { + my $me = shift; + $me->_command("QUIT"); + my ($num, $txt) = $me->_response(); + if(not $num == 221){ + croak "An error occurred disconnecting from the mail server: $num $txt\n"; + } +} + +1; |