File Coverage

lib/Sisimai/Lhost/Notes.pm
Criterion Covered Total %
statement 65 71 91.5
branch 21 34 61.7
condition 5 9 55.5
subroutine 7 7 100.0
pod 2 2 100.0
total 100 123 81.3


line stmt bran cond sub pod time code
1             package Sisimai::Lhost::Notes;
2 16     16   5465 use parent 'Sisimai::Lhost';
  16         34  
  16         140  
3 16     16   869 use feature ':5.10';
  16         26  
  16         1007  
4 16     16   76 use strict;
  16         21  
  16         309  
5 16     16   77 use warnings;
  16         36  
  16         372  
6 16     16   74 use Encode;
  16         24  
  16         12358  
7              
8 2     2 1 1007 sub description { 'Lotus Notes' }
9             sub make {
10             # Detect an error from Lotus Notes
11             # @param [Hash] mhead Message headers of a bounce email
12             # @param [String] mbody Message body of a bounce email
13             # @return [Hash] Bounce data list and message/rfc822 part
14             # @return [Undef] failed to parse or the arguments are missing
15             # @since v4.1.1
16 209     209 1 666 my $class = shift;
17 209   100     481 my $mhead = shift // return undef;
18 208   50     461 my $mbody = shift // return undef;
19 208 100       742 return undef unless index($mhead->{'subject'}, 'Undeliverable message') == 0;
20              
21 16         42 state $indicators = __PACKAGE__->INDICATORS;
22 16         33 state $rebackbone = qr|^-------[ ]Returned[ ]Message[ ]--------|m;
23 16         39 state $startingof = { 'message' => ['------- Failure Reasons '] };
24 16         32 state $messagesof = {
25             'userunknown' => [
26             'User not listed in public Name & Address Book',
27             'ディレクトリのリストにありません',
28             ],
29             'networkerror' => ['Message has exceeded maximum hop count'],
30             };
31              
32 16         62 my $dscontents = [__PACKAGE__->DELIVERYSTATUS];
33 16         82 my $emailsteak = Sisimai::RFC5322->fillet($mbody, $rebackbone);
34 16         53 my $readcursor = 0; # (Integer) Points the current cursor position
35 16         23 my $recipients = 0; # (Integer) The number of 'Final-Recipient' header
36 16         35 my $removedmsg = 'MULTIBYTE CHARACTERS HAVE BEEN REMOVED';
37 16         22 my $encodedmsg = '';
38 16         21 my $v = undef;
39              
40             # Get character set name, Content-Type: text/plain; charset=ISO-2022-JP
41 16 50       115 my $characters = $mhead->{'content-type'} =~ /\A.+;[ ]*charset=(.+)\z/ ? lc $1 : '';
42              
43 16         70 for my $e ( split("\n", $emailsteak->[0]) ) {
44             # Read error messages and delivery status lines from the head of the email
45             # to the previous line of the beginning of the original message.
46 64 100       115 unless( $readcursor ) {
47             # Beginning of the bounce message or message/delivery-status part
48 16 50       93 $readcursor |= $indicators->{'deliverystatus'} if index($e, $startingof->{'message'}->[0]) == 0;
49 16         24 next;
50             }
51 48 50       87 next unless $readcursor & $indicators->{'deliverystatus'};
52              
53             # ------- Failure Reasons --------
54             #
55             # User not listed in public Name & Address Book
56             # kijitora@notes.example.jp
57             #
58             # ------- Returned Message --------
59 48         54 $v = $dscontents->[-1];
60 48 100       122 if( $e =~ /\A[^ ]+[@][^ ]+/ ) {
61             # kijitora@notes.example.jp
62 16 50       48 if( $v->{'recipient'} ) {
63             # There are multiple recipient addresses in the message body.
64 0         0 push @$dscontents, __PACKAGE__->DELIVERYSTATUS;
65 0         0 $v = $dscontents->[-1];
66             }
67 16   33     67 $v->{'recipient'} ||= $e;
68 16         29 $recipients++;
69              
70             } else {
71 32 100       80 next if $e eq '';
72 16 50       34 next if index($e, '-') == 0;
73              
74 16 100       56 if( $e =~ /[^\x20-\x7e]/ ) {
75             # Error message is not ISO-8859-1
76 11         19 $encodedmsg = $e;
77 11 50       16 if( $characters ) {
78             # Try to convert string
79 11         14 eval { Encode::from_to($encodedmsg, $characters, 'utf8'); };
  11         46  
80 11 50       1735 $encodedmsg = $removedmsg if $@; # Failed to convert
81              
82             } else {
83             # No character set in Content-Type header
84 0         0 $encodedmsg = $removedmsg;
85             }
86 11         31 $v->{'diagnosis'} .= $encodedmsg;
87              
88             } else {
89             # Error message does not include multi-byte character
90 5         14 $v->{'diagnosis'} .= $e;
91             }
92             }
93             }
94              
95 16 50       42 unless( $recipients ) {
96             # Fallback: Get the recpient address from RFC822 part
97 0 0       0 if( $emailsteak->[1] =~ /^To:[ ]*(.+)$/m ) {
98 0         0 $v->{'recipient'} = Sisimai::Address->s3s4($1);
99 0 0       0 $recipients++ if $v->{'recipient'};
100             }
101             }
102 16 50       39 return undef unless $recipients;
103              
104 16         41 for my $e ( @$dscontents ) {
105 16         98 $e->{'diagnosis'} = Sisimai::String->sweep($e->{'diagnosis'});
106 16         87 $e->{'recipient'} = Sisimai::Address->s3s4($e->{'recipient'});
107              
108 16         74 for my $r ( keys %$messagesof ) {
109             # Check each regular expression of Notes error messages
110 30 100       43 next unless grep { index($e->{'diagnosis'}, $_) > -1 } @{ $messagesof->{ $r } };
  46         197  
  30         61  
111 10         28 $e->{'reason'} = $r;
112 10   50     57 $e->{'status'} = Sisimai::SMTP::Status->code($r) || '';
113 10         29 last;
114             }
115             }
116 16         81 return { 'ds' => $dscontents, 'rfc822' => $emailsteak->[1] };
117             }
118              
119             1;
120             __END__