File Coverage

lib/Sisimai/Lhost/KDDI.pm
Criterion Covered Total %
statement 61 65 93.8
branch 27 36 75.0
condition 9 18 50.0
subroutine 6 6 100.0
pod 2 2 100.0
total 105 127 82.6


line stmt bran cond sub pod time code
1             package Sisimai::Lhost::KDDI;
2 21     21   6123 use parent 'Sisimai::Lhost';
  21         43  
  21         118  
3 21     21   1267 use feature ':5.10';
  21         41  
  21         1381  
4 21     21   112 use strict;
  21         65  
  21         432  
5 21     21   86 use warnings;
  21         64  
  21         19510  
6              
7 2     2 1 1891 sub description { 'au by KDDI: https://www.au.kddi.com' }
8             sub make {
9             # Detect an error from au by KDDI
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 245     245 1 1023 my $class = shift;
16 245   100     755 my $mhead = shift // return undef;
17 244   50     699 my $mbody = shift // return undef;
18 244         316 my $match = 0;
19              
20             # 'message-id' => qr/[@].+[.]ezweb[.]ne[.]jp[>]\z/,
21 244 100 50     1032 $match ||= 1 if $mhead->{'from'} =~ /no-reply[@].+[.]dion[.]ne[.]jp/;
22 244 100 50     1038 $match ||= 1 if $mhead->{'reply-to'} && $mhead->{'reply-to'} eq 'no-reply@app.auone-net.jp';
      100        
23 244 50 0     396 $match ||= 1 if grep { rindex($_, 'ezweb.ne.jp (') > -1 } @{ $mhead->{'received'} };
  475         1354  
  244         688  
24 244 50 0     408 $match ||= 1 if grep { rindex($_, '.au.com (') > -1 } @{ $mhead->{'received'} };
  475         1226  
  244         659  
25 244 100       782 return undef unless $match;
26              
27 16         53 state $indicators = __PACKAGE__->INDICATORS;
28 16         34 state $rebackbone = qr|^Content-Type:[ ]message/rfc822|m;
29 16         34 state $markingsof = {
30             'message' => qr/\AYour[ ]mail[ ](?:
31             sent[ ]on:?[ ][A-Z][a-z]{2}[,]
32             |attempted[ ]to[ ]be[ ]delivered[ ]on:?[ ][A-Z][a-z]{2}[,]
33             )
34             /x,
35             };
36 16         39 state $messagesof = {
37             'mailboxfull' => ['As their mailbox is full'],
38             'norelaying' => ['Due to the following SMTP relay error'],
39             'hostunknown' => ['As the remote domain doesnt exist'],
40             };
41              
42 16         61 my $dscontents = [__PACKAGE__->DELIVERYSTATUS];
43 16         89 my $emailsteak = Sisimai::RFC5322->fillet($mbody, $rebackbone);
44 16         39 my $readcursor = 0; # (Integer) Points the current cursor position
45 16         35 my $recipients = 0; # (Integer) The number of 'Final-Recipient' header
46 16         25 my $v = undef;
47              
48 16         114 for my $e ( split("\n", $emailsteak->[0]) ) {
49             # Read error messages and delivery status lines from the head of the email
50             # to the previous line of the beginning of the original message.
51 138 100       214 unless( $readcursor ) {
52             # Beginning of the bounce message or message/delivery-status part
53 106 100       353 $readcursor |= $indicators->{'deliverystatus'} if $e =~ $markingsof->{'message'};
54             }
55 138 100       264 next unless $readcursor & $indicators->{'deliverystatus'};
56 48 50       78 next unless length $e;
57              
58 48         75 $v = $dscontents->[-1];
59 48 100       243 if( $e =~ /\A[ \t]+Could not be delivered to: [<]([^ ]+[@][^ ]+)[>]/ ) {
    100          
60             # Your mail sent on: Thu, 29 Apr 2010 11:04:47 +0900
61             # Could not be delivered to: <******@**.***.**>
62             # As their mailbox is full.
63 16 50       57 if( $v->{'recipient'} ) {
64             # There are multiple recipient addresses in the message body.
65 0         0 push @$dscontents, __PACKAGE__->DELIVERYSTATUS;
66 0         0 $v = $dscontents->[-1];
67             }
68              
69 16         114 my $r = Sisimai::Address->s3s4($1);
70 16 50       73 next unless Sisimai::RFC5322->is_emailaddress($r);
71 16         50 $v->{'recipient'} = $r;
72 16         31 $recipients++;
73              
74             } elsif( $e =~ /Your mail sent on: (.+)\z/ ) {
75             # Your mail sent on: Thu, 29 Apr 2010 11:04:47 +0900
76 16         72 $v->{'date'} = $1;
77              
78             } else {
79             # As their mailbox is full.
80 16 50       98 $v->{'diagnosis'} .= $e.' ' if $e =~ /\A[ \t]+/;
81             }
82             }
83 16 50       64 return undef unless $recipients;
84              
85 16         39 for my $e ( @$dscontents ) {
86 16         65 $e->{'diagnosis'} = Sisimai::String->sweep($e->{'diagnosis'});
87              
88 16 50 33     80 if( defined $mhead->{'x-spasign'} && $mhead->{'x-spasign'} eq 'NG' ) {
89             # Content-Type: text/plain; ..., X-SPASIGN: NG (spamghetti, au by KDDI)
90             # Filtered recipient returns message that include 'X-SPASIGN' header
91 0         0 $e->{'reason'} = 'filtered';
92              
93             } else {
94 16 50       48 if( $e->{'command'} eq 'RCPT' ) {
95             # set "userunknown" when the remote server rejected after RCPT
96             # command.
97 0         0 $e->{'reason'} = 'userunknown';
98              
99             } else {
100             # SMTP command is not RCPT
101 16         62 SESSION: for my $r ( keys %$messagesof ) {
102             # Verify each regular expression of session errors
103 40 100       52 next unless grep { index($e->{'diagnosis'}, $_) > -1 } @{ $messagesof->{ $r } };
  40         159  
  40         74  
104 16         59 $e->{'reason'} = $r;
105 16         39 last;
106             }
107             }
108             }
109             }
110 16         85 return { 'ds' => $dscontents, 'rfc822' => $emailsteak->[1] };
111             }
112              
113             1;
114             __END__