File Coverage

lib/Sisimai/RFC1894.pm
Criterion Covered Total %
statement 45 45 100.0
branch 19 20 95.0
condition 11 12 91.6
subroutine 6 6 100.0
pod 2 3 66.6
total 83 86 96.5


line stmt bran cond sub pod time code
1             package Sisimai::RFC1894;
2 53     53   69909 use feature ':5.10';
  53         102  
  53         4124  
3 53     53   290 use strict;
  53         90  
  53         985  
4 53     53   233 use warnings;
  53         84  
  53         44833  
5              
6             sub FIELDTABLE {
7             # Return pairs that a field name and key name defined in Sisimai::Lhost class
8             return {
9 1947     1947 0 17615 'action' => 'action',
10             'arrival-date' => 'date',
11             'diagnostic-code' => 'diagnosis',
12             'final-recipient' => 'recipient',
13             'last-attempt-date' => 'date',
14             'original-recipient'=> 'alias',
15             'received-from-mta' => 'lhost',
16             'remote-mta' => 'rhost',
17             'reporting-mta' => 'rhost',
18             'status' => 'status',
19             'x-actual-recipient'=> 'alias',
20             };
21             }
22              
23             sub match {
24             # Check the argument matches with a field defined in RFC3464
25             # @param [String] argv0 A line inlcuding field and value defined in RFC3464
26             # @return [Integer] 0: did not matched, 1,2: matched
27             # @since v4.25.0
28 30398     30398 1 57769 my $class = shift;
29 30398   100     42204 my $argv0 = shift || return undef;
30              
31 30029         27812 state $fieldnames = [
32             # https://tools.ietf.org/html/rfc3464#section-2.2
33             # Some fields of a DSN apply to all of the delivery attempts described by
34             # that DSN. At most, these fields may appear once in any DSN. These fields
35             # are used to correlate the DSN with the original message transaction and
36             # to provide additional information which may be useful to gateways.
37             #
38             # The following fields (not defined in RFC 3464) are used in Sisimai
39             # - X-Original-Message-ID: <....> (GSuite)
40             #
41             # The following fields are not used in Sisimai:
42             # - Original-Envelope-Id
43             # - DSN-Gateway
44             [qw|Reporting-MTA Received-From-MTA Arrival-Date X-Original-Message-ID|],
45              
46             # https://tools.ietf.org/html/rfc3464#section-2.3
47             # A DSN contains information about attempts to deliver a message to one or
48             # more recipients. The delivery information for any particular recipient is
49             # contained in a group of contiguous per-recipient fields.
50             # Each group of per-recipient fields is preceded by a blank line.
51             #
52             # The following fields (not defined in RFC 3464) are used in Sisimai
53             # - X-Actual-Recipient: RFC822; ....
54             #
55             # The following fields are not used in Sisimai:
56             # - Will-Retry-Until
57             # - Final-Log-ID
58             [qw|Original-Recipient Final-Recipient Action Status Remote-MTA
59             Diagnostic-Code Last-Attempt-Date X-Actual-Recipient|],
60             ];
61              
62 30029 100       29369 return 1 if grep { index($argv0, $_) == 0 } @{ $fieldnames->[0] };
  120116         203873  
  30029         42960  
63 26685 100       27789 return 2 if grep { index($argv0, $_) == 0 } @{ $fieldnames->[1] };
  213480         300920  
  26685         32623  
64 18614         37730 return 0;
65             }
66              
67             sub field {
68             # Check the argument is including field defined in RFC3464 and return values
69             # @param [String] argv0 A line inlcuding field and value defined in RFC3464
70             # @return [Array] ['field-name', 'value-type', 'Value', 'field-group']
71             # @since v4.25.0
72 11419     11419 1 13465 my $class = shift;
73 11419   50     16601 my $argv0 = shift || return undef;
74              
75 11419         12048 state $correction = {
76             'action' => { 'deliverable' => 'delivered', 'expired' => 'delayed', 'failure' => 'failed' },
77             };
78 11419         11685 state $fieldgroup = {
79             'original-recipient' => 'addr',
80             'final-recipient' => 'addr',
81             'x-actual-recipient' => 'addr',
82             'diagnostic-code' => 'code',
83             'arrival-date' => 'date',
84             'last-attempt-date' => 'date',
85             'received-from-mta' => 'host',
86             'remote-mta' => 'host',
87             'reporting-mta' => 'host',
88             'action' => 'list',
89             'status' => 'stat',
90             'x-original-message-id' => 'text',
91             };
92 11419         11403 state $captureson = {
93             'addr' => qr/\A((?:Original|Final|X-Actual)-Recipient):[ ]*(.+?);[ ]*(.+)/,
94             'code' => qr/\A(Diagnostic-Code):[ ]*(.+?);[ ]*(.*)/,
95             'date' => qr/\A((?:Arrival|Last-Attempt)-Date):[ ]*(.+)/,
96             'host' => qr/\A((?:Received-From|Remote|Reporting)-MTA):[ ]*(.+?);[ ]*(.+)/,
97             'list' => qr/\A(Action):[ ]*(delayed|deliverable|delivered|expanded|expired|failed|failure|relayed)/i,
98             'stat' => qr/\A(Status):[ ]*([245][.]\d+[.]\d+)/,
99             'text' => qr/\A(X-Original-Message-ID):[ ]*(.+)/,
100             #'text' => qr/\A(Final-Log-ID|Original-Envelope-Id):[ ]*(.+)/,
101             };
102              
103 11419   100     37534 my $group = $fieldgroup->{ lc((split(':', $argv0, 2))[0]) } || return undef;
104 11415 50       23606 return undef unless exists $captureson->{ $group };
105              
106 11415         20872 my $table = ['', '', '', ''];
107 11415         12631 my $match = 0;
108 11415         70430 while( $argv0 =~ $captureson->{ $group } ) {
109             # Try to match with each pattern of Per-Message field, Per-Recipient field
110             # - 0: Field-Name
111             # - 1: Sub Type: RFC822, DNS, X-Unix, and so on)
112             # - 2: Value
113             # - 3: Field Group(addr, code, date, host, stat, text)
114 11342         15617 $match = 1;
115 11342         25074 $table->[0] = lc $1;
116 11342         13254 $table->[3] = $group;
117              
118 11342 100 100     42608 if( $group eq 'addr' || $group eq 'code' || $group eq 'host' ) {
      100        
119             # - Final-Recipient: RFC822; kijitora@nyaan.jp
120             # - Diagnostic-Code: SMTP; 550 5.1.1 ... User Unknown
121             # - Remote-MTA: DNS; mx.example.jp
122 6389         12656 $table->[1] = uc $2;
123 6389 100       14299 $table->[2] = $group eq 'host' ? lc $3 : $3;
124 6389 100       16604 $table->[2] = '' if $table->[2] =~ /\A\s+\z/; # Remote-MTA: dns;
125              
126             } else {
127             # - Action: failed
128             # - Status: 5.2.2
129 4953         6641 $table->[1] = '';
130 4953 100       11160 $table->[2] = $group eq 'date' ? $2 : lc $2;
131              
132             # Correct invalid value in Action field:
133 4953 100       9299 last unless $group eq 'list';
134 1506 100       4031 last unless exists $correction->{'action'}->{ $table->[2] };
135 5         28 $table->[2] = $correction->{'action'}->{ $table->[2] };
136             }
137 6394         7443 last;
138             }
139              
140 11415 100       16416 return undef unless $match;
141 11342         27054 return $table;
142             }
143              
144             1;
145             __END__