|  line  | 
 stmt  | 
 bran  | 
 cond  | 
 sub  | 
 pod  | 
 time  | 
 code  | 
| 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 package Haineko::SMTPD::Relay::File;  | 
| 
2
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
6602
 | 
 use parent 'Haineko::SMTPD::Relay';  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
367
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
5
 | 
    | 
| 
3
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
45
 | 
 use strict;  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
3
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
33
 | 
    | 
| 
4
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
5
 | 
 use warnings;  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
27
 | 
    | 
| 
5
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
656
 | 
 use Haineko::SMTPD::Response;  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
34
 | 
    | 
| 
6
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
1297
 | 
 use Email::MIME;  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
88214
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
53
 | 
    | 
| 
7
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
1151
 | 
 use Time::Piece;  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
13723
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
6
 | 
    | 
| 
8
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
906
 | 
 use Try::Tiny;  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1802
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
66
 | 
    | 
| 
9
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
980
 | 
 use IO::File;  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
11655
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
170
 | 
    | 
| 
10
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
10
 | 
 use Encode;  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
913
 | 
    | 
| 
11
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
12
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub new {  | 
| 
13
 | 
3
 | 
 
 | 
 
 | 
  
3
  
 | 
  
1
  
 | 
707
 | 
     my $class = shift;  | 
| 
14
 | 
3
 | 
 
 | 
 
 | 
 
 | 
 
 | 
12
 | 
     my $argvs = { @_ };  | 
| 
15
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
16
 | 
3
 | 
 
 | 
  
 50
  
 | 
 
 | 
 
 | 
22
 | 
     $argvs->{'host'}    ||= '/tmp';  | 
| 
17
 | 
3
 | 
 
 | 
  
 66
  
 | 
 
 | 
 
 | 
26
 | 
     $argvs->{'port'}      = undef,  | 
| 
18
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     $argvs->{'time'}    ||= Time::Piece->new;  | 
| 
19
 | 
3
 | 
 
 | 
 
 | 
 
 | 
 
 | 
440
 | 
     $argvs->{'sleep'}     = 0;  | 
| 
20
 | 
3
 | 
 
 | 
 
 | 
 
 | 
 
 | 
8
 | 
     $argvs->{'retry'}     = 0;  | 
| 
21
 | 
3
 | 
 
 | 
 
 | 
 
 | 
 
 | 
6
 | 
     $argvs->{'timeout'}   = 0;  | 
| 
22
 | 
3
 | 
 
 | 
 
 | 
 
 | 
 
 | 
8
 | 
     $argvs->{'startls'}   = 0;  | 
| 
23
 | 
3
 | 
 
 | 
 
 | 
 
 | 
 
 | 
13
 | 
     return bless $argvs, __PACKAGE__;  | 
| 
24
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 }  | 
| 
25
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
26
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub sendmail {  | 
| 
27
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
  
1
  
 | 
3970
 | 
     my $self = shift;  | 
| 
28
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
29
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
3
 | 
     my $headerlist = [];  | 
| 
30
 | 
1
 | 
 
 | 
  
 50
  
 | 
 
 | 
 
 | 
10
 | 
     my $emencoding = uc( $self->{'attr'}->{'charset'} || 'UTF-8' );  | 
| 
31
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
8
 | 
     my $methodargv = {  | 
| 
32
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2
 | 
         'body' => Encode::encode( $emencoding, ${ $self->{'body'} } ),  | 
| 
33
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
         'attributes' => $self->{'attr'},  | 
| 
34
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     };  | 
| 
35
 | 
1
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
199
 | 
     utf8::decode $methodargv->{'body'} unless utf8::is_utf8 $methodargv->{'body'} ;  | 
| 
36
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
37
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2
 | 
     for my $e ( @{ $self->{'head'}->{'Received'} } ) {  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
7
 | 
    | 
| 
38
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
         # Convert email headers  | 
| 
39
 | 
0
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
         push @$headerlist, 'Received' => $e;  | 
| 
40
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     }  | 
| 
41
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
4
 | 
     push @$headerlist, 'To' => $self->{'rcpt'};  | 
| 
42
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
43
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2
 | 
     for my $e ( keys %{ $self->{'head'} } ) {  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
6
 | 
    | 
| 
44
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
         # Make email headers except ``Received'' and ``MIME-Version''  | 
| 
45
 | 
5
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
15
 | 
         next if $e eq 'Received';  | 
| 
46
 | 
4
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
10
 | 
         next if $e eq 'MIME-Version';  | 
| 
47
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
48
 | 
4
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
11
 | 
         if( ref $self->{'head'}->{ $e } eq 'ARRAY' ) {  | 
| 
49
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
50
 | 
0
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
             for my $f ( @{ $self->{'head'}->{ $e } } ) {  | 
| 
 
 | 
0
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
    | 
| 
51
 | 
0
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
                 push @$headerlist, $e => $f;  | 
| 
52
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
             }  | 
| 
53
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
         }  | 
| 
54
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
         else {   | 
| 
55
 | 
4
 | 
 
 | 
 
 | 
 
 | 
 
 | 
11
 | 
             push @$headerlist, $e => $self->{'head'}->{ $e };  | 
| 
56
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
         }  | 
| 
57
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     }  | 
| 
58
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
4
 | 
     $methodargv->{'header'} = $headerlist;  | 
| 
59
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
60
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
13
 | 
     my $mimeobject = Email::MIME->create( %$methodargv );  | 
| 
61
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
3384
 | 
     my $mailstring = $mimeobject->as_string;  | 
| 
62
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
94
 | 
     my $mailfolder = $self->{'host'};  | 
| 
63
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
4
 | 
     my $messageid0 = undef;  | 
| 
64
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
65
 | 
1
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
6
 | 
     if( exists $self->{'head'}->{'Message-Id'} ) {  | 
| 
66
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
         # Use the local part of the Message-Id header as a file name.  | 
| 
67
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
7
 | 
         $messageid0 = [ split( '@', $self->{'head'}->{'Message-Id'} ) ]->[0];  | 
| 
68
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
69
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     } else {  | 
| 
70
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
         # Message-Id header is not defined or does not exist  | 
| 
71
 | 
0
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
         require Haineko::SMTPD::Session;  | 
| 
72
 | 
0
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
         $messageid0 = sprintf( "%s.%d.%d.%03d",   | 
| 
73
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
                         Haineko::SMTPD::Session->make_queueid, $$,  | 
| 
74
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
                         $self->time->epoch, int(rand(100)) );  | 
| 
75
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     }  | 
| 
76
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
77
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
6
 | 
     my $timestring = sprintf( "%s-%s", $self->time->ymd('-'), $self->time->hms );  | 
| 
78
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
47
 | 
     my $outputfile = sprintf( "%s/haineko.%s.%s.eml", $mailfolder, $timestring, $messageid0 );  | 
| 
79
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2
 | 
     my $filehandle = undef;  | 
| 
80
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2
 | 
     my $smtpparams = undef;  | 
| 
81
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2
 | 
     my $smtpstatus = 0;  | 
| 
82
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
83
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     try {  | 
| 
84
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
46
 | 
         $outputfile =~ y{/}{}s;  | 
| 
85
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
12
 | 
         $smtpparams = {  | 
| 
86
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
             'dsn'     => undef,  | 
| 
87
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
             'code'    => 200,  | 
| 
88
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
             'host'    => undef,  | 
| 
89
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
             'port'    => undef,  | 
| 
90
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
             'rcpt'    => $self->{'rcpt'},  | 
| 
91
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
             'error'   => 0,  | 
| 
92
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
             'mailer'  => 'File',  | 
| 
93
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
             'message' => [ $outputfile ],  | 
| 
94
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
             'command' => 'DATA',  | 
| 
95
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
         };  | 
| 
96
 | 
1
 | 
 
 | 
  
 50
  
 | 
 
 | 
 
 | 
10
 | 
         $filehandle =  IO::File->new( $outputfile, 'w' ) || die $!;  | 
| 
97
 | 
1
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
291
 | 
         utf8::encode $mailstring if utf8::is_utf8 $mailstring;  | 
| 
98
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
99
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
11
 | 
         $filehandle->print( $mailstring );  | 
| 
100
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
151
 | 
         $filehandle->close;  | 
| 
101
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
230
 | 
         push @{ $smtpparams->{'message'} }, 'Successfully saved';  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
4
 | 
    | 
| 
102
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
5
 | 
         $smtpstatus = 1;  | 
| 
103
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
104
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     } catch {  | 
| 
105
 | 
0
 | 
 
 | 
 
 | 
  
0
  
 | 
 
 | 
0
 | 
         require Haineko::E;  | 
| 
106
 | 
0
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
         my $E = Haineko::E->new( $_ );  | 
| 
107
 | 
0
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
         $smtpparams->{'code'} = 400;  | 
| 
108
 | 
0
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
         $smtpparams->{'error'} = 1;  | 
| 
109
 | 
0
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
         push @{ $smtpparams->{'message'} }, 'Failed to save: '.join( ' ', @{ $E->mesg } );  | 
| 
 
 | 
0
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
    | 
| 
 
 | 
0
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
    | 
| 
110
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
23
 | 
     };  | 
| 
111
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
112
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
42
 | 
     $self->response( Haineko::SMTPD::Response->new( %$smtpparams ) );  | 
| 
113
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
39
 | 
     return $smtpstatus;  | 
| 
114
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 }  | 
| 
115
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
116
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 1;  | 
| 
117
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 __END__  |