File Coverage

lib/Haineko/SMTPD/Relay/ESMTP.pm
Criterion Covered Total %
statement 76 131 58.0
branch 11 58 18.9
condition 10 18 55.5
subroutine 13 13 100.0
pod 2 2 100.0
total 112 222 50.4


line stmt bran cond sub pod time code
1             package Haineko::SMTPD::Relay::ESMTP;
2 1     1   250209 use parent 'Haineko::SMTPD::Relay';
  1         356  
  1         6  
3 1     1   39 use strict;
  1         2  
  1         27  
4 1     1   5 use warnings;
  1         1  
  1         22  
5 1     1   152381 use Net::SMTP;
  1         271819  
  1         74  
6 1     1   1083 use Module::Load;
  1         1046  
  1         5  
7 1     1   420 use Haineko::SMTPD::Response;
  1         4  
  1         62  
8 1     1   562 use Haineko::SMTPD::Greeting;
  1         3  
  1         34  
9 1     1   5967 use Email::MIME;
  1         128698  
  1         13406  
10 1     1   1116 use Time::Piece;
  1         33511  
  1         7  
11 1     1   107 use Encode;
  1         3  
  1         2274  
12              
13             sub new {
14 3     3 1 7464 my $class = shift;
15 3         16 my $argvs = { @_ };
16              
17 3   66     52 $argvs->{'time'} ||= Time::Piece->new;
18 3   100     428 $argvs->{'sleep'} ||= 5;
19 3   100     17 $argvs->{'timeout'} ||= 30;
20 3         15 return bless $argvs, __PACKAGE__;
21             }
22              
23             sub sendmail {
24 1     1 1 7420 my $self = shift;
25              
26 1 50       5 my $esmtpclass = $self->{'starttls'} ? 'Net::SMTPS' : 'Net::SMTP';
27 1         3 my $headerlist = [];
28 1   50     11 my $emencoding = uc( $self->{'attr'}->{'charset'} || 'UTF-8' );
29 1         6 my $methodargv = {
30 1         2 'body' => Encode::encode( $emencoding, ${ $self->{'body'} } ),
31             'attributes' => $self->{'attr'},
32             };
33 1 50       198 utf8::decode $methodargv->{'body'} unless utf8::is_utf8 $methodargv->{'body'} ;
34              
35 1         2 for my $e ( @{ $self->{'head'}->{'Received'} } ) {
  1         5  
36             # Convert email headers
37 0         0 push @$headerlist, 'Received' => $e;
38             }
39 1         4 push @$headerlist, 'To' => $self->{'rcpt'};
40              
41 1         2 for my $e ( keys %{ $self->{'head'} } ) {
  1         6  
42             # Make email headers except ``Received'' and ``MIME-Version''
43 4 100       12 next if $e eq 'Received';
44 3 50       7 next if $e eq 'MIME-Version';
45              
46 3 50       8 if( ref $self->{'head'}->{ $e } eq 'ARRAY' ) {
47              
48 0         0 for my $f ( @{ $self->{'head'}->{ $e } } ) {
  0         0  
49 0         0 push @$headerlist, $e => $f;
50             }
51             }
52             else {
53 3         10 push @$headerlist, $e => $self->{'head'}->{ $e };
54             }
55             }
56 1         5 $methodargv->{'header'} = $headerlist;
57              
58 1         14 my $mimeobject = Email::MIME->create( %$methodargv );
59 1         3804 my $mailstring = $mimeobject->as_string;
60 1         90 my $maillength = length $mailstring;
61              
62 1   50     19 my $smtpparams = {
      50        
63             'Port' => $self->{'port'},
64             'Hello' => $self->{'ehlo'},
65             'Debug' => $self->{'debug'} || 0,
66             'Timeout' => $self->{'timeout'} || 30,
67             };
68              
69 1 50       6 if( $self->{'starttls'} ) {
70             # Sendmail using TLS(Net::SMTPS)
71 0         0 Module::Load::load('Net::SMTPS');
72 0         0 $smtpparams->{'doSSL'} = 'starttls';
73 0         0 $smtpparams->{'SSL_verify_mode'} = 'SSL_VERIFY_NONE';
74             }
75              
76 1         2 my $netsmtpobj = undef;
77 1         2 my $authensasl = undef;
78 1         2 my $nekogreets = undef;
79 1         2 my $smtpstatus = 0;
80 1         3 my $thecommand = q();
81 1         3 my $pipelining = q();
82 1   50     11 my $retryuntil = $self->{'retry'} || 0;
83              
84             my $sendmailto = sub {
85              
86 1     1   3 $thecommand = 'ehlo';
87 1 50       19 return 0 unless $netsmtpobj = $esmtpclass->new( $self->{'host'}, %$smtpparams );
88 0         0 $nekogreets = Haineko::SMTPD::Greeting->new( $netsmtpobj->message );
89              
90 0 0 0     0 if( $nekogreets->auth && $self->{'auth'} ) {
91             # SMTP-AUTH
92 0         0 require Authen::SASL;
93 0         0 $authensasl = Authen::SASL->new(
94 0         0 'mechanism' => join( ' ', @{ $nekogreets->mechanism } ),
95             'callback' => {
96             'user' => $self->{'username'},
97             'pass' => $self->{'password'},
98             'authname' => $self->{'username'},
99             },
100             );
101 0         0 $thecommand = 'auth';
102 0 0       0 return 0 unless $netsmtpobj->auth( $authensasl );
103             }
104              
105 0 0       0 if( $nekogreets->pipelining ) {
106             # 250-PIPELINING
107 0         0 $thecommand = 'data';
108 0         0 $pipelining = sprintf( "MAIL FROM: <%s>", $self->{'mail'} );
109 0 0       0 $pipelining .= sprintf( ' RET=FULL' ) if $nekogreets->dsn;
110 0 0       0 $pipelining .= sprintf( " SIZE=%d", $maillength ) if $nekogreets->size;
111 0         0 $pipelining .= sprintf( "\r\n" );
112 0         0 $pipelining .= sprintf( "RCPT TO: <%s>", $self->{'rcpt'} );
113 0 0       0 $pipelining .= sprintf( ' NOTIFY=FAILURE,DELAY' ) if $nekogreets->dsn;
114 0         0 $pipelining .= sprintf( "\r\n" );
115 0         0 $pipelining .= sprintf( "DATA\r\n" );
116 0         0 $pipelining .= sprintf( "%s", $mailstring );
117 0 0       0 return 0 unless $netsmtpobj->datasend( $pipelining );
118 0 0       0 return 0 unless $netsmtpobj->dataend();
119              
120             } else {
121             # External SMTP Server does not support PIPELINING
122 0         0 my $cmdargvs = [];
123 0         0 my $cmdparam = {};
124              
125 0         0 $thecommand = 'mail';
126 0         0 $cmdargvs = [ $self->{'mail'} ];
127 0 0       0 $cmdparam->{'Return'} = 'FULL' if $nekogreets->dsn;
128 0 0       0 $cmdparam->{'Size'} = $maillength if $nekogreets->size;
129 0 0       0 push @$cmdargvs, %$cmdparam if keys %$cmdparam;
130 0 0       0 return 0 unless $netsmtpobj->mail( @$cmdargvs );
131              
132 0         0 $thecommand = 'rcpt';
133 0         0 $cmdargvs = [ $self->{'rcpt'} ];
134 0         0 $cmdparam = {};
135 0 0       0 $cmdparam->{'Notify'} = [ 'FAILURE', 'DELAY' ] if $nekogreets->dsn;
136 0 0       0 push @$cmdargvs, %$cmdparam if keys %$cmdparam;
137 0 0       0 return 0 unless $netsmtpobj->to( @$cmdargvs );
138              
139 0         0 $thecommand = 'data';
140 0 0       0 return 0 unless $netsmtpobj->data();
141 0 0       0 return 0 unless $netsmtpobj->datasend( $mailstring );
142 0 0       0 return 0 unless $netsmtpobj->dataend();
143             }
144              
145 0         0 $thecommand = 'QUIT';
146 0         0 $netsmtpobj->quit;
147 0         0 $smtpstatus = 1;
148 0         0 return 1;
149 1         19 };
150              
151 1         3 while(1) {
152 1 50       3 last if $sendmailto->();
153 1 50       2004788 last if $retryuntil == 0;
154              
155 0 0       0 $netsmtpobj->quit if defined $netsmtpobj;
156 0         0 $retryuntil--;
157 0         0 sleep $self->{'sleep'};
158             }
159              
160 1 50       9 if( defined $netsmtpobj ) {
161             # Check the response from SMTP server
162 0         0 $smtpparams = {
163             'code' => $netsmtpobj->code,
164             'host' => $self->{'host'},
165             'port' => $self->{'port'},
166             'rcpt' => $self->{'rcpt'},
167             'mailer' => 'ESMTP',
168             'message' => [ $netsmtpobj->message ],
169             'command' => $thecommand,
170             };
171 0         0 $self->response( Haineko::SMTPD::Response->p( %$smtpparams ) );
172 0         0 $netsmtpobj->quit;
173              
174             } else {
175 1         16 $self->response( Haineko::SMTPD::Response->r( 'conn', 'cannot-connect' ) );
176 1         10 map { $self->response->{ $_ } = $self->{ $_ } } ( qw|host port rcpt| );
  3         22  
177             }
178 1         90 return $smtpstatus;
179             }
180              
181             1;
182             __END__