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   5283 use parent 'Sisimai::Lhost';
  16         30  
  16         86  
3 16     16   958 use feature ':5.10';
  16         30  
  16         1057  
4 16     16   81 use strict;
  16         30  
  16         325  
5 16     16   79 use warnings;
  16         30  
  16         398  
6 16     16   72 use Encode;
  16         37  
  16         14081  
7              
8 2     2 1 977 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 677 my $class = shift;
17 209   100     622 my $mhead = shift // return undef;
18 208   50     719 my $mbody = shift // return undef;
19 208 100       892 return undef unless index($mhead->{'subject'}, 'Undeliverable message') == 0;
20              
21 16         54 state $indicators = __PACKAGE__->INDICATORS;
22 16         38 state $rebackbone = qr|^-------[ ]Returned[ ]Message[ ]--------|m;
23 16         31 state $startingof = { 'message' => ['------- Failure Reasons '] };
24 16         35 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         71 my $dscontents = [__PACKAGE__->DELIVERYSTATUS];
33 16         85 my $emailsteak = Sisimai::RFC5322->fillet($mbody, $rebackbone);
34 16         35 my $readcursor = 0; # (Integer) Points the current cursor position
35 16         37 my $recipients = 0; # (Integer) The number of 'Final-Recipient' header
36 16         30 my $removedmsg = 'MULTIBYTE CHARACTERS HAVE BEEN REMOVED';
37 16         27 my $encodedmsg = '';
38 16         22 my $v = undef;
39              
40             # Get character set name, Content-Type: text/plain; charset=ISO-2022-JP
41 16 50       134 my $characters = $mhead->{'content-type'} =~ /\A.+;[ ]*charset=(.+)\z/ ? lc $1 : '';
42              
43 16         84 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       130 unless( $readcursor ) {
47             # Beginning of the bounce message or message/delivery-status part
48 16 50       100 $readcursor |= $indicators->{'deliverystatus'} if index($e, $startingof->{'message'}->[0]) == 0;
49 16         32 next;
50             }
51 48 50       97 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         69 $v = $dscontents->[-1];
60 48 100       135 if( $e =~ /\A[^ ]+[@][^ ]+/ ) {
61             # kijitora@notes.example.jp
62 16 50       53 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     83 $v->{'recipient'} ||= $e;
68 16         33 $recipients++;
69              
70             } else {
71 32 100       79 next if $e eq '';
72 16 50       48 next if index($e, '-') == 0;
73              
74 16 100       61 if( $e =~ /[^\x20-\x7e]/ ) {
75             # Error message is not ISO-8859-1
76 11         22 $encodedmsg = $e;
77 11 50       26 if( $characters ) {
78             # Try to convert string
79 11         22 eval { Encode::from_to($encodedmsg, $characters, 'utf8'); };
  11         68  
80 11 50       1909 $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         36 $v->{'diagnosis'} .= $encodedmsg;
87              
88             } else {
89             # Error message does not include multi-byte character
90 5         18 $v->{'diagnosis'} .= $e;
91             }
92             }
93             }
94              
95 16 50       71 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       47 return undef unless $recipients;
103              
104 16         39 for my $e ( @$dscontents ) {
105 16         93 $e->{'diagnosis'} = Sisimai::String->sweep($e->{'diagnosis'});
106 16         89 $e->{'recipient'} = Sisimai::Address->s3s4($e->{'recipient'});
107              
108 16         96 for my $r ( keys %$messagesof ) {
109             # Check each regular expression of Notes error messages
110 22 100       43 next unless grep { index($e->{'diagnosis'}, $_) > -1 } @{ $messagesof->{ $r } };
  38         161  
  22         54  
111 10         28 $e->{'reason'} = $r;
112 10   50     99 $e->{'status'} = Sisimai::SMTP::Status->code($r) || '';
113 10         31 last;
114             }
115             }
116 16         101 return { 'ds' => $dscontents, 'rfc822' => $emailsteak->[1] };
117             }
118              
119             1;
120             __END__