File Coverage

lib/Sisimai/Lhost/Sendmail.pm
Criterion Covered Total %
statement 96 97 98.9
branch 62 72 86.1
condition 23 34 67.6
subroutine 6 6 100.0
pod 2 2 100.0
total 189 211 89.5


line stmt bran cond sub pod time code
1             package Sisimai::Lhost::Sendmail;
2 38     38   5908 use parent 'Sisimai::Lhost';
  38         91  
  38         259  
3 38     38   2596 use feature ':5.10';
  38         67  
  38         3164  
4 38     38   253 use strict;
  38         67  
  38         854  
5 38     38   191 use warnings;
  38         61  
  38         56712  
6              
7 2     2 1 978 sub description { 'V8Sendmail: /usr/sbin/sendmail' }
8             sub make {
9             # Parse bounce messages from Sendmail
10             # @param [Hash] mhead Message headers of a bounce email
11             # @param [String] mbody Message body of a bounce email
12             # @return [Hash] Bounce data list and message/rfc822 part
13             # @return [Undef] failed to parse or the arguments are missing
14             # @since v4.0.0
15 799     799 1 1594 my $class = shift;
16 799   100     2138 my $mhead = shift // return undef;
17 798   50     1973 my $mbody = shift // return undef;
18              
19 798 100       5483 return undef unless $mhead->{'subject'} =~ /(?:see transcript for details\z|\AWarning: )/;
20 491 50       1328 return undef if $mhead->{'x-aol-ip'}; # X-AOL-IP is a header defined in AOL
21              
22 491         930 state $indicators = __PACKAGE__->INDICATORS;
23 491         1108 state $rebackbone = qr<^Content-Type:[ ](?:message/rfc822|text/rfc822-headers)>m;
24 491         808 state $startingof = {
25             # savemail.c:1040|if (printheader && !putline(" ----- Transcript of session follows -----\n",
26             # savemail.c:1041| mci))
27             # savemail.c:1042| goto writeerr;
28             # savemail.c:1360|if (!putline(
29             # savemail.c:1361| sendbody
30             # savemail.c:1362| ? " ----- Original message follows -----\n"
31             # savemail.c:1363| : " ----- Message header follows -----\n",
32             'message' => [' ----- Transcript of session follows -----'],
33             'error' => ['... while talking to '],
34             };
35              
36 491         6182 require Sisimai::RFC1894;
37 491         2031 my $fieldtable = Sisimai::RFC1894->FIELDTABLE;
38 491         948 my $permessage = {}; # (Hash) Store values of each Per-Message field
39              
40 491         1703 my $dscontents = [__PACKAGE__->DELIVERYSTATUS];
41 491         2265 my $emailsteak = Sisimai::RFC5322->fillet($mbody, $rebackbone);
42 491         882 my $readcursor = 0; # (Integer) Points the current cursor position
43 491         750 my $recipients = 0; # (Integer) The number of 'Final-Recipient' header
44 491         768 my $commandtxt = ''; # (String) SMTP Command name begin with the string '>>>'
45 491         694 my $esmtpreply = []; # (Array) Reply from remote server on SMTP session
46 491         709 my $sessionerr = 0; # (Integer) Flag, 1 if it is SMTP session error
47 491         813 my $anotherset = {}; # (Hash) Another error information
48 491         633 my $v = undef;
49 491         624 my $p = '';
50              
51 491         4975 for my $e ( split("\n", $emailsteak->[0]) ) {
52             # Read error messages and delivery status lines from the head of the email
53             # to the previous line of the beginning of the original message.
54 13399 100       18387 unless( $readcursor ) {
55             # Beginning of the bounce message or message/delivery-status part
56 5301 100       10582 $readcursor |= $indicators->{'deliverystatus'} if index($e, $startingof->{'message'}->[0]) == 0;
57 5301         5528 next;
58             }
59 8098 50       13250 next unless $readcursor & $indicators->{'deliverystatus'};
60 8098 100       11493 next unless length $e;
61              
62 7113 100       12408 if( my $f = Sisimai::RFC1894->match($e) ) {
63             # $e matched with any field defined in RFC3464
64 4161 50       7355 next unless my $o = Sisimai::RFC1894->field($e);
65 4161         5811 $v = $dscontents->[-1];
66              
67 4161 100       7829 if( $o->[-1] eq 'addr' ) {
    100          
68             # Final-Recipient: rfc822; kijitora@example.jp
69             # X-Actual-Recipient: rfc822; kijitora@example.co.jp
70 530 100       1191 if( $o->[0] eq 'final-recipient' ) {
71             # Final-Recipient: rfc822; kijitora@example.jp
72 485 100       1432 if( $v->{'recipient'} ) {
73             # There are multiple recipient addresses in the message body.
74 11         74 push @$dscontents, __PACKAGE__->DELIVERYSTATUS;
75 11         28 $v = $dscontents->[-1];
76             }
77 485         870 $v->{'recipient'} = $o->[2];
78 485         1013 $recipients++;
79              
80             } else {
81             # X-Actual-Recipient: rfc822; kijitora@example.co.jp
82 45         153 $v->{'alias'} = $o->[2];
83             }
84             } elsif( $o->[-1] eq 'code' ) {
85             # Diagnostic-Code: SMTP; 550 5.1.1 ... User Unknown
86 455         888 $v->{'spec'} = $o->[1];
87 455         1048 $v->{'diagnosis'} = $o->[2];
88              
89             } else {
90             # Other DSN fields defined in RFC3464
91 3176 50       6053 next unless exists $fieldtable->{ $o->[0] };
92 3176         6179 $v->{ $fieldtable->{ $o->[0] } } = $o->[2];
93              
94 3176 100       6269 next unless $f == 1;
95 1348         3677 $permessage->{ $fieldtable->{ $o->[0] } } = $o->[2];
96             }
97             } else {
98             # The line does not begin with a DSN field defined in RFC3464
99             #
100             # ----- Transcript of session follows -----
101             # ... while talking to mta.example.org.:
102             # >>> DATA
103             # <<< 550 Unknown user recipient@example.jp
104             # 554 5.0.0 Service unavailable
105 2952 100       5158 if( substr($e, 0, 1) ne ' ') {
106             # Other error messages
107 2941 100       8327 if( $e =~ /\A[>]{3}[ ]+([A-Z]{4})[ ]?/ ) {
    100          
108             # >>> DATA
109 463         1144 $commandtxt = $1;
110              
111             } elsif( $e =~ /\A[<]{3}[ ]+(.+)\z/ ) {
112             # <<< Response
113 805 100       2667 push @$esmtpreply, $1 unless grep { $1 eq $_ } @$esmtpreply;
  709         2127  
114              
115             } else {
116             # Detect SMTP session error or connection error
117 1673 100       3015 next if $sessionerr;
118 619 100       1939 if( index($e, $startingof->{'error'}->[0]) == 0 ) {
119             # ----- Transcript of session follows -----
120             # ... while talking to mta.example.org.:
121 404         692 $sessionerr = 1;
122 404         627 next;
123             }
124              
125 215 100       559 if( $e =~ /\A[<](.+)[>][.]+ (.+)\z/ ) {
126             # ... Deferred: Name server: example.co.jp.: host name lookup failure
127 10         45 $anotherset->{'recipient'} = $1;
128 10         33 $anotherset->{'diagnosis'} = $2;
129              
130             } else {
131             # ----- Transcript of session follows -----
132             # Message could not be delivered for too long
133             # Message will be deleted from queue
134 205 100 66     1012 if( $e =~ /\A[45]\d\d[ \t]([45][.]\d[.]\d)[ \t].+/ ) {
    100          
135             # 550 5.1.2 ... Message
136             #
137             # DBI connect('dbname=...')
138             # 554 5.3.0 unknown mailer error 255
139 46         255 $anotherset->{'status'} = $1;
140 46         196 $anotherset->{'diagnosis'} .= ' '.$e;
141              
142             } elsif( index($e, 'Message: ') == 0 || index($e, 'Warning: ') == 0 ) {
143             # Message could not be delivered for too long
144             # Warning: message still undelivered after 4 hours
145 5         25 $anotherset->{'diagnosis'} .= ' '.$e;
146             }
147             }
148             }
149             } else {
150             # Continued line of the value of Diagnostic-Code field
151 11 100       61 next unless index($p, 'Diagnostic-Code:') == 0;
152 6 50       38 next unless $e =~ /\A[ \t]+(.+)\z/;
153 6         25 $v->{'diagnosis'} .= ' '.$1;
154             }
155             }
156             } continue {
157             # Save the current line for the next loop
158 13399         18689 $p = $e;
159             }
160 491 100       2379 return undef unless $recipients;
161              
162 474         1078 for my $e ( @$dscontents ) {
163             # Set default values if each value is empty.
164 485   66     1365 $e->{'lhost'} ||= $permessage->{'rhost'};
165 485   50     2848 $e->{ $_ } ||= $permessage->{ $_ } || '' for keys %$permessage;
      66        
166 485   100     2803 $e->{'command'} ||= $commandtxt || '';
      66        
167 485 100 100     1514 $e->{'command'} ||= 'EHLO' if scalar @$esmtpreply;
168              
169 485 50 66     1551 if( exists $anotherset->{'diagnosis'} && $anotherset->{'diagnosis'} ) {
170             # Copy alternative error message
171 56 50       226 $e->{'diagnosis'} = $anotherset->{'diagnosis'} if $e->{'diagnosis'} =~ /\A[ \t]+\z/;
172 56   66     234 $e->{'diagnosis'} ||= $anotherset->{'diagnosis'};
173 56 100       306 $e->{'diagnosis'} = $anotherset->{'diagnosis'} if $e->{'diagnosis'} =~ /\A\d+\z/;
174             }
175 485 100       1141 if( scalar @$esmtpreply ) {
176             # Replace the error message in "diagnosis" with the ESMTP Reply
177 415         1178 my $r = join(' ', @$esmtpreply);
178 415 100       1624 $e->{'diagnosis'} = $r if length($r) > length($e->{'diagnosis'});
179             }
180 485         2727 $e->{'diagnosis'} = Sisimai::String->sweep($e->{'diagnosis'});
181              
182 485 50 66     1618 if( exists $anotherset->{'status'} && $anotherset->{'status'} ) {
183             # Check alternative status code
184 46 50 33     383 if( ! $e->{'status'} || $e->{'status'} !~ /\A[45][.]\d[.]\d{1,3}\z/ ) {
185             # Override alternative status code
186 0         0 $e->{'status'} = $anotherset->{'status'};
187             }
188             }
189              
190             # @example.jp, no local part
191             # Get email address from the value of Diagnostic-Code header
192 485 100       2870 next if $e->{'recipient'} =~ /\A[^ ]+[@][^ ]+\z/;
193 5 50       49 $e->{'recipient'} = $1 if $e->{'diagnosis'} =~ /[<]([^ ]+[@][^ ]+)[>]/;
194             }
195 474         3833 return { 'ds' => $dscontents, 'rfc822' => $emailsteak->[1] };
196             }
197              
198             1;
199             __END__