File Coverage

lib/Sisimai/Lhost/Aol.pm
Criterion Covered Total %
statement 70 70 100.0
branch 29 34 85.2
condition 7 12 58.3
subroutine 6 6 100.0
pod 2 2 100.0
total 114 124 91.9


line stmt bran cond sub pod time code
1             package Sisimai::Lhost::Aol;
2 30     30   6043 use parent 'Sisimai::Lhost';
  30         58  
  30         168  
3 30     30   1845 use feature ':5.10';
  30         54  
  30         2024  
4 30     30   180 use strict;
  30         57  
  30         677  
5 30     30   139 use warnings;
  30         58  
  30         24563  
6              
7 2     2 1 1140 sub description { 'Aol Mail: https://www.aol.com' }
8             sub make {
9             # Detect an error from Aol Mail
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.3
15 410     410 1 1095 my $class = shift;
16 410   100     1200 my $mhead = shift // return undef;
17 409   50     1094 my $mbody = shift // return undef;
18              
19             # X-AOL-IP: 192.0.2.135
20             # X-AOL-VSS-INFO: 5600.1067/98281
21             # X-AOL-VSS-CODE: clean
22             # x-aol-sid: 3039ac1afc14546fb98a0945
23             # X-AOL-SCOLL-EIL: 1
24             # x-aol-global-disposition: G
25             # x-aol-sid: 3039ac1afd4d546fb97d75c6
26             # X-BounceIO-Id: 9D38DE46-21BC-4309-83E1-5F0D788EFF1F.1_0
27             # X-Outbound-Mail-Relay-Queue-ID: 07391702BF4DC
28             # X-Outbound-Mail-Relay-Sender: rfc822; shironeko@aol.example.jp
29 409 100       1366 return undef unless $mhead->{'x-aol-ip'};
30              
31 31         70 state $indicators = __PACKAGE__->INDICATORS;
32 31         79 state $rebackbone = qr|^Content-Type:[ ]message/rfc822|m;
33 31         63 state $startingof = { 'message' => ['Content-Type: message/delivery-status'] };
34 31         66 state $messagesof = {
35             'hostunknown' => ['Host or domain name not found'],
36             'notaccept' => ['type=MX: Malformed or unexpected name server reply'],
37             };
38              
39 31         457 require Sisimai::RFC1894;
40 31         173 my $fieldtable = Sisimai::RFC1894->FIELDTABLE;
41 31         64 my $permessage = {}; # (Hash) Store values of each Per-Message field
42              
43 31         143 my $dscontents = [__PACKAGE__->DELIVERYSTATUS];
44 31         181 my $emailsteak = Sisimai::RFC5322->fillet($mbody, $rebackbone);
45 31         77 my $readcursor = 0; # (Integer) Points the current cursor position
46 31         67 my $recipients = 0; # (Integer) The number of 'Final-Recipient' header
47 31         54 my $v = undef;
48 31         63 my $p = '';
49              
50 31         453 for my $e ( split("\n", $emailsteak->[0]) ) {
51             # Read error messages and delivery status lines from the head of the email
52             # to the previous line of the beginning of the original message.
53 944 100       1299 unless( $readcursor ) {
54             # Beginning of the bounce message or message/delivery-status part
55 264 100       618 $readcursor |= $indicators->{'deliverystatus'} if index($e, $startingof->{'message'}->[0]) == 0;
56 264         292 next;
57             }
58 680 50       1180 next unless $readcursor & $indicators->{'deliverystatus'};
59 680 100       954 next unless length $e;
60              
61 650 100       1095 if( my $f = Sisimai::RFC1894->match($e) ) {
62             # $e matched with any field defined in RFC3464
63 262 50       552 next unless my $o = Sisimai::RFC1894->field($e);
64 262         428 $v = $dscontents->[-1];
65              
66 262 100       537 if( $o->[-1] eq 'addr' ) {
    100          
67             # Final-Recipient: rfc822; kijitora@example.jp
68             # X-Actual-Recipient: rfc822; kijitora@example.co.jp
69 72 100       165 if( $o->[0] eq 'final-recipient' ) {
70             # Final-Recipient: rfc822; kijitora@example.jp
71 36 100       113 if( $v->{'recipient'} ) {
72             # There are multiple recipient addresses in the message body.
73 5         23 push @$dscontents, __PACKAGE__->DELIVERYSTATUS;
74 5         16 $v = $dscontents->[-1];
75             }
76 36         66 $v->{'recipient'} = $o->[2];
77 36         96 $recipients++;
78              
79             } else {
80             # X-Actual-Recipient: rfc822; kijitora@example.co.jp
81 36         106 $v->{'alias'} = $o->[2];
82             }
83             } elsif( $o->[-1] eq 'code' ) {
84             # Diagnostic-Code: SMTP; 550 5.1.1 ... User Unknown
85 36         115 $v->{'spec'} = $o->[1];
86 36         113 $v->{'diagnosis'} = $o->[2];
87              
88             } else {
89             # Other DSN fields defined in RFC3464
90 154 50       319 next unless exists $fieldtable->{ $o->[0] };
91 154         311 $v->{ $fieldtable->{ $o->[0] } } = $o->[2];
92              
93 154 100       364 next unless $f == 1;
94 62         218 $permessage->{ $fieldtable->{ $o->[0] } } = $o->[2];
95             }
96             } else {
97             # Continued line of the value of Diagnostic-Code field
98 388 100       787 next unless index($p, 'Diagnostic-Code:') == 0;
99 16 50       103 next unless $e =~ /\A[ \t]+(.+)\z/;
100 16         74 $v->{'diagnosis'} .= ' '.$1;
101             }
102             } continue {
103             # Save the current line for the next loop
104 944         1308 $p = $e;
105             }
106 31 50       209 return undef unless $recipients;
107              
108 31         103 for my $e ( @$dscontents ) {
109             # Set default values if each value is empty.
110 36   33     181 $e->{'lhost'} ||= $permessage->{'rhost'};
111 36   50     264 $e->{ $_ } ||= $permessage->{ $_ } || '' for keys %$permessage;
      66        
112              
113 36         97 $e->{'diagnosis'} =~ y/\n/ /;
114 36         195 $e->{'diagnosis'} = Sisimai::String->sweep($e->{'diagnosis'});
115 36         129 SESSION: for my $r ( keys %$messagesof ) {
116             # Verify each regular expression of session errors
117 66 100       87 next unless grep { index($e->{'diagnosis'}, $_) > -1 } @{ $messagesof->{ $r } };
  66         287  
  66         150  
118 16         36 $e->{'reason'} = $r;
119 16         39 last;
120             }
121             }
122 31         248 return { 'ds' => $dscontents, 'rfc822' => $emailsteak->[1] };
123             }
124              
125             1;
126             __END__