File Coverage

lib/Sisimai/Lhost/V5sendmail.pm
Criterion Covered Total %
statement 64 68 94.1
branch 28 38 73.6
condition 10 18 55.5
subroutine 6 6 100.0
pod 2 2 100.0
total 110 132 83.3


line stmt bran cond sub pod time code
1             package Sisimai::Lhost::V5sendmail;
2 19     19   5470 use parent 'Sisimai::Lhost';
  19         32  
  19         101  
3 19     19   1030 use feature ':5.10';
  19         34  
  19         1184  
4 19     19   89 use strict;
  19         27  
  19         392  
5 19     19   78 use warnings;
  19         36  
  19         17088  
6              
7 2     2 1 1023 sub description { 'Sendmail version 5' }
8             sub make {
9             # Detect an error from V5sendmail
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.1.2
15 251     251 1 652 my $class = shift;
16 251   100     640 my $mhead = shift // return undef;
17 250   50     592 my $mbody = shift // return undef;
18              
19             # 'from' => qr/\AMail Delivery Subsystem/,
20 250 100       946 return undef unless $mhead->{'subject'} =~ /\AReturned mail: [A-Z]/;
21              
22 79         225 state $indicators = __PACKAGE__->INDICATORS;
23 79         139 state $rebackbone = qr/^[ ]+-----[ ](?:Unsent[ ]message[ ]follows|No[ ]message[ ]was[ ]collected)[ ]-----/m;
24 79         195 state $startingof = { 'message' => ['----- Transcript of session follows -----'] };
25 79         125 state $markingsof = {
26             # Error text regular expressions which defined in src/savemail.c
27             # savemail.c:485| (void) fflush(stdout);
28             # savemail.c:486| p = queuename(e->e_parent, 'x');
29             # savemail.c:487| if ((xfile = fopen(p, "r")) == NULL)
30             # savemail.c:488| {
31             # savemail.c:489| syserr("Cannot open %s", p);
32             # savemail.c:490| fprintf(fp, " ----- Transcript of session is unavailable -----\n");
33             # savemail.c:491| }
34             # savemail.c:492| else
35             # savemail.c:493| {
36             # savemail.c:494| fprintf(fp, " ----- Transcript of session follows -----\n");
37             # savemail.c:495| if (e->e_xfp != NULL)
38             # savemail.c:496| (void) fflush(e->e_xfp);
39             # savemail.c:497| while (fgets(buf, sizeof buf, xfile) != NULL)
40             # savemail.c:498| putline(buf, fp, m);
41             # savemail.c:499| (void) fclose(xfile);
42             'error' => qr/\A[.]+ while talking to .+[:]\z/,
43             };
44              
45 79         396 my $emailsteak = Sisimai::RFC5322->fillet($mbody, $rebackbone);
46 79 100       348 return undef unless length $emailsteak->[1];
47              
48 36         167 my $dscontents = [__PACKAGE__->DELIVERYSTATUS];
49 36         65 my $readcursor = 0; # (Integer) Points the current cursor position
50 36         72 my $recipients = 0; # (Integer) The number of 'Final-Recipient' header
51 36         63 my $anotherset = {}; # (Ref->Hash) Another error information
52 36         63 my @responding; # (Array) Responses from remote server
53             my @commandset; # (Array) SMTP command which is sent to remote server
54 36         53 my $errorindex = -1;
55 36         51 my $v = undef;
56              
57 36         180 for my $e ( split("\n", $emailsteak->[0]) ) {
58             # Read error messages and delivery status lines from the head of the email
59             # to the previous line of the beginning of the original message.
60 262 100       425 unless( $readcursor ) {
61             # Beginning of the bounce message or message/delivery-status part
62 36 50       241 $readcursor |= $indicators->{'deliverystatus'} if index($e, $startingof->{'message'}->[0]) > -1;
63 36         78 next;
64             }
65 226 50       334 next unless $readcursor & $indicators->{'deliverystatus'};
66 226 50       291 next unless length $e;
67              
68             # ----- Transcript of session follows -----
69             # While talking to smtp.example.com:
70             # >>> RCPT To:
71             # <<< 550 , User Unknown
72             # 550 ... User unknown
73             # 421 example.org (smtp)... Deferred: Connection timed out during user open with example.org
74 226         229 $v = $dscontents->[-1];
75              
76 226 100       793 if( $e =~ /\A\d{3}[ \t]+[<]([^ ]+[@][^ ]+)[>][.]{3}[ \t]*(.+)\z/ ) {
    100          
    100          
77             # 550 ... User unknown
78 60 100       135 if( $v->{'recipient'} ) {
79             # There are multiple recipient addresses in the message body.
80 30         80 push @$dscontents, __PACKAGE__->DELIVERYSTATUS;
81 30         59 $v = $dscontents->[-1];
82             }
83 60         113 $v->{'recipient'} = $1;
84 60         108 $v->{'diagnosis'} = $2;
85              
86 60 100       127 if( $responding[ $recipients ] ) {
87             # Concatenate the response of the server and error message
88 30         72 $v->{'diagnosis'} .= ': '.$responding[$recipients];
89             }
90 60         77 $recipients++;
91              
92             } elsif( $e =~ /\A[>]{3}[ \t]*([A-Z]{4})[ \t]*/ ) {
93             # >>> RCPT To:
94 35         101 $commandset[ $recipients ] = $1;
95              
96             } elsif( $e =~ /\A[<]{3}[ ]+(.+)\z/ ) {
97             # <<< Response
98             # <<< 501 ... no access from mail server [192.0.2.55] which is an open relay.
99             # <<< 550 Requested User Mailbox not found. No such user here.
100 35         103 $responding[ $recipients ] = $1;
101              
102             } else {
103             # Detect SMTP session error or connection error
104 96 50       192 next if $v->{'sessionerr'};
105 96 50       323 if( $e =~ $markingsof->{'error'} ) {
106             # ----- Transcript of session follows -----
107             # ... while talking to mta.example.org.:
108 0         0 $v->{'sessionerr'} = 1;
109 0         0 next;
110             }
111              
112             # 421 example.org (smtp)... Deferred: Connection timed out during user open with example.org
113 96 100       462 $anotherset->{'diagnosis'} = $1 if $e =~ /\A\d{3}[ \t]+.+[.]{3}[ \t]*(.+)\z/;
114             }
115             }
116              
117 36 100 66     176 if( $recipients == 0 && $emailsteak->[1] =~ /^To:[ ]*(.+)/m ) {
118             # Get the recipient address from "To:" header at the original message
119 6         41 $dscontents->[0]->{'recipient'} = Sisimai::Address->s3s4($1);
120 6         13 $recipients = 1;
121             }
122 36 50       82 return undef unless $recipients;
123              
124 36         70 for my $e ( @$dscontents ) {
125 66         73 $errorindex++;
126 66         107 delete $e->{'sessionerr'};
127 66   100     182 $e->{'command'} = $commandset[$errorindex] || '';
128              
129 66 50 33     245 if( exists $anotherset->{'diagnosis'} && $anotherset->{'diagnosis'} ) {
130             # Copy alternative error message
131 66   66     132 $e->{'diagnosis'} ||= $anotherset->{'diagnosis'};
132              
133             } else {
134             # Set server response as a error message
135 0   0     0 $e->{'diagnosis'} ||= $responding[$errorindex];
136             }
137 66         284 $e->{'diagnosis'} = Sisimai::String->sweep($e->{'diagnosis'});
138              
139             # @example.jp, no local part
140             # Get email address from the value of Diagnostic-Code header
141 66 50       317 next if $e->{'recipient'} =~ /\A[^ ]+[@][^ ]+\z/;
142 0 0       0 $e->{'recipient'} = $1 if $e->{'diagnosis'} =~ /[<]([^ ]+[@][^ ]+)[>]/;
143             }
144 36         194 return { 'ds' => $dscontents, 'rfc822' => $emailsteak->[1] };
145             }
146              
147             1;
148             __END__