line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Mail::Milter::Authentication::Tester::HandlerTester; |
2
|
|
|
|
|
|
|
|
3
|
8
|
|
|
8
|
|
235232
|
use strict; |
|
8
|
|
|
|
|
62
|
|
|
8
|
|
|
|
|
230
|
|
4
|
8
|
|
|
8
|
|
40
|
use warnings; |
|
8
|
|
|
|
|
14
|
|
|
8
|
|
|
|
|
287
|
|
5
|
|
|
|
|
|
|
our $VERSION = '20191206'; # VERSION |
6
|
|
|
|
|
|
|
|
7
|
8
|
|
|
8
|
|
39
|
use Carp; |
|
8
|
|
|
|
|
15
|
|
|
8
|
|
|
|
|
555
|
|
8
|
8
|
|
|
8
|
|
2509
|
use Clone qw{ clone }; |
|
8
|
|
|
|
|
14414
|
|
|
8
|
|
|
|
|
388
|
|
9
|
8
|
|
|
8
|
|
2805
|
use English qw{ -no_match_vars }; |
|
8
|
|
|
|
|
20928
|
|
|
8
|
|
|
|
|
42
|
|
10
|
8
|
|
|
8
|
|
5352
|
use Mail::AuthenticationResults::Header; |
|
8
|
|
|
|
|
80362
|
|
|
8
|
|
|
|
|
228
|
|
11
|
8
|
|
|
8
|
|
51
|
use Mail::AuthenticationResults::Header::AuthServID; |
|
8
|
|
|
|
|
18
|
|
|
8
|
|
|
|
|
136
|
|
12
|
8
|
|
|
8
|
|
3499
|
use Mail::Milter::Authentication; |
|
8
|
|
|
|
|
53
|
|
|
8
|
|
|
|
|
586
|
|
13
|
8
|
|
|
8
|
|
57
|
use Mail::Milter::Authentication::Config qw{ set_config get_config default_config }; |
|
8
|
|
|
|
|
19
|
|
|
8
|
|
|
|
|
531
|
|
14
|
8
|
|
|
8
|
|
53
|
use Mail::Milter::Authentication::Constants qw{ :all }; |
|
8
|
|
|
|
|
18
|
|
|
8
|
|
|
|
|
1952
|
|
15
|
8
|
|
|
8
|
|
56
|
use Mail::Milter::Authentication::Protocol::Milter; |
|
8
|
|
|
|
|
16
|
|
|
8
|
|
|
|
|
147
|
|
16
|
8
|
|
|
8
|
|
71
|
use Mail::Milter::Authentication::Protocol::SMTP; |
|
8
|
|
|
|
|
18
|
|
|
8
|
|
|
|
|
154
|
|
17
|
8
|
|
|
8
|
|
47
|
use Module::Load; |
|
8
|
|
|
|
|
17
|
|
|
8
|
|
|
|
|
54
|
|
18
|
8
|
|
|
8
|
|
3316
|
use Net::DNS::Resolver::Mock; |
|
8
|
|
|
|
|
40932
|
|
|
8
|
|
|
|
|
260
|
|
19
|
8
|
|
|
8
|
|
52
|
use Net::IP; |
|
8
|
|
|
|
|
17
|
|
|
8
|
|
|
|
|
15464
|
|
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
sub _build_config_smtp { |
22
|
5
|
|
|
5
|
|
17
|
my ( $self, $handler_config ) = @_; |
23
|
|
|
|
|
|
|
|
24
|
5
|
|
|
|
|
89
|
my $config = { |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
'_is_test' => 1, |
27
|
|
|
|
|
|
|
'debug' => 1, |
28
|
|
|
|
|
|
|
'dryrun' => 0, |
29
|
|
|
|
|
|
|
'logtoerr' => 1, |
30
|
|
|
|
|
|
|
'error_log' => 'tmp/smtp.err', |
31
|
|
|
|
|
|
|
'connection' => 'unix:tmp/authentication_milter_test.sock', |
32
|
|
|
|
|
|
|
'umask' => '0000', |
33
|
|
|
|
|
|
|
'connect_timeout' => 55, |
34
|
|
|
|
|
|
|
'command_timeout' => 55, |
35
|
|
|
|
|
|
|
'content_timeout' => 595, |
36
|
|
|
|
|
|
|
'tempfail_on_error' => 1, |
37
|
|
|
|
|
|
|
'tempfail_on_error_authenticated' => 1, |
38
|
|
|
|
|
|
|
'tempfail_on_error_local' => 1, |
39
|
|
|
|
|
|
|
'tempfail_on_error_trusted' => 1, |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
'#metric_connection' => 'unix:tmp/authentication_milter_test_metrics.sock', |
42
|
|
|
|
|
|
|
'#metric_umask' => '0000', |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
'protocol' => 'smtp', |
45
|
|
|
|
|
|
|
'smtp' => { |
46
|
|
|
|
|
|
|
'sock_type' => 'unix', |
47
|
|
|
|
|
|
|
'sock_path' => 'tmp/authentication_milter_smtp_out.sock', |
48
|
|
|
|
|
|
|
'pipeline_limit' => '4', |
49
|
|
|
|
|
|
|
}, |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
'handlers' => $handler_config, |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
}; |
54
|
|
|
|
|
|
|
|
55
|
5
|
|
|
|
|
59
|
return $config; |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
sub _build_config_milter { |
59
|
4
|
|
|
4
|
|
10
|
my ( $self, $handler_config ) = @_; |
60
|
|
|
|
|
|
|
|
61
|
4
|
|
|
|
|
46
|
my $config = { |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
'_is_test' => 1, |
64
|
|
|
|
|
|
|
'debug' => 1, |
65
|
|
|
|
|
|
|
'dryrun' => 0, |
66
|
|
|
|
|
|
|
'logtoerr' => 1, |
67
|
|
|
|
|
|
|
'error_log' => 'tmp/milter.err', |
68
|
|
|
|
|
|
|
'connection' => 'unix:tmp/authentication_milter_test.sock', |
69
|
|
|
|
|
|
|
'umask' => '0000', |
70
|
|
|
|
|
|
|
'connect_timeout' => 55, |
71
|
|
|
|
|
|
|
'command_timeout' => 55, |
72
|
|
|
|
|
|
|
'content_timeout' => 595, |
73
|
|
|
|
|
|
|
'tempfail_on_error' => 1, |
74
|
|
|
|
|
|
|
'tempfail_on_error_authenticated' => 1, |
75
|
|
|
|
|
|
|
'tempfail_on_error_local' => 1, |
76
|
|
|
|
|
|
|
'tempfail_on_error_trusted' => 1, |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
'#metric_connection' => 'unix:tmp/authentication_milter_test_metrics.sock', |
79
|
|
|
|
|
|
|
'#metric_umask' => '0000', |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
'protocol' => 'milter', |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
'handlers' => $handler_config, |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
}; |
86
|
|
|
|
|
|
|
|
87
|
4
|
|
|
|
|
32
|
return $config; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
sub new { |
91
|
9
|
|
|
9
|
1
|
774350
|
my ( $class, $args ) = @_; |
92
|
9
|
|
|
|
|
23
|
my $self = {}; |
93
|
9
|
|
|
|
|
28
|
bless $self, $class; |
94
|
|
|
|
|
|
|
|
95
|
9
|
|
|
|
|
83
|
$self->{ 'snapshots' } = {}; |
96
|
|
|
|
|
|
|
|
97
|
9
|
|
|
|
|
33
|
foreach my $arg ( qw{ prefix zonefile zonedata } ) { |
98
|
27
|
100
|
|
|
|
95
|
$self->{ $arg } = $args->{ $arg } if exists $args->{ $arg }; |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
9
|
50
|
|
|
|
36
|
croak 'prefix must be supplies' if ! exists $self->{ 'prefix' }; |
102
|
9
|
50
|
66
|
|
|
45
|
croak 'zonefile or zonedata cannot both be supplied' if ( exists $self->{ 'zonefile' } ) && ( exists $self->{ 'zonedata' }); |
103
|
9
|
50
|
66
|
|
|
80
|
$self->{ 'zonedata' } = q{} if ( ! exists $self->{ 'zonefile' } ) && ( ! exists $self->{ 'zonedata' }); |
104
|
|
|
|
|
|
|
|
105
|
9
|
|
100
|
|
|
45
|
my $protocol = $args->{ 'protocol' } // 'smtp'; |
106
|
|
|
|
|
|
|
|
107
|
9
|
50
|
|
|
|
40
|
if ( exists( $args->{ 'handler_config' } ) ) { |
108
|
9
|
100
|
|
|
|
38
|
if ( $protocol eq 'smtp' ) { |
109
|
5
|
|
|
|
|
26
|
set_config( $self->_build_config_smtp( $args->{ 'handler_config' } ) ); |
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
else { |
112
|
4
|
|
|
|
|
17
|
set_config( $self->_build_config_milter( $args->{ 'handler_config' } ) ); |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
9
|
|
|
|
|
30
|
$Mail::Milter::Authentication::Config::PREFIX = $self->{ 'prefix' }; |
117
|
9
|
|
|
|
|
39
|
my $config = get_config(); |
118
|
|
|
|
|
|
|
|
119
|
9
|
|
|
|
|
152
|
my $Resolver = Net::DNS::Resolver::Mock->new(); |
120
|
9
|
100
|
|
|
|
2885
|
$Resolver->zonefile_read( $self->{ 'zonefile' } ) if exists $self->{ 'zonefile' }; |
121
|
9
|
100
|
|
|
|
50131
|
$Resolver->zonefile_parse( $self->{ 'zonedata' } ) if exists $self->{ 'zonedata' }; |
122
|
9
|
|
|
|
|
12722
|
$Mail::Milter::Authentication::Handler::TestResolver = $Resolver; |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
# Setup a new authentication milter object |
125
|
9
|
|
|
|
|
174
|
my $authmilter = Mail::Milter::Authentication->new(); |
126
|
9
|
|
|
|
|
186
|
$authmilter->{'metric'} = Mail::Milter::Authentication::Metric->new(); |
127
|
9
|
|
|
|
|
30
|
$authmilter->{'config'} = $config; |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
# if ( $protocol eq 'smtp' ) { |
130
|
9
|
|
|
|
|
174
|
push @Mail::Milter::Authentication::ISA, 'Mail::Milter::Authentication::Protocol::SMTP'; |
131
|
|
|
|
|
|
|
#} |
132
|
|
|
|
|
|
|
#else { |
133
|
|
|
|
|
|
|
#push @Mail::Milter::Authentication::ISA, 'Mail::Milter::Authentication::Protocol::Milter'; |
134
|
|
|
|
|
|
|
#} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# Setup a fake server object |
137
|
9
|
|
|
|
|
73
|
$authmilter->{ 'server' }->{ 'ppid' } = $PID; |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
# Load handlers |
140
|
9
|
|
|
|
|
21
|
foreach my $name ( @{$config->{'load_handlers'}} ) { |
|
9
|
|
|
|
|
34
|
|
141
|
16
|
|
|
|
|
103
|
$authmilter->load_handler( $name ); |
142
|
|
|
|
|
|
|
|
143
|
16
|
|
|
|
|
57
|
my $package = "Mail::Milter::Authentication::Handler::$name"; |
144
|
16
|
|
|
|
|
174
|
my $object = $package->new( $authmilter ); |
145
|
16
|
100
|
|
|
|
126
|
if ( $object->can( 'pre_loop_setup' ) ) { |
146
|
3
|
|
|
|
|
13
|
$object->pre_loop_setup(); |
147
|
|
|
|
|
|
|
} |
148
|
16
|
50
|
|
|
|
79
|
if ( $object->can( 'register_metrics' ) ) { |
149
|
16
|
|
|
|
|
69
|
$authmilter->{'metric'}->register_metrics( $object->register_metrics() ); |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
# Init handlers |
155
|
|
|
|
|
|
|
|
156
|
9
|
|
|
|
|
26
|
my $callbacks_list = {}; |
157
|
9
|
|
|
|
|
19
|
my $callbacks = {}; |
158
|
9
|
|
|
|
|
19
|
my $handler = {}; |
159
|
9
|
|
|
|
|
19
|
my $object = {}; |
160
|
9
|
|
|
|
|
16
|
my $object_maker = {}; |
161
|
9
|
|
|
|
|
23
|
my $count = 0; |
162
|
|
|
|
|
|
|
|
163
|
9
|
|
|
|
|
27
|
$authmilter->{'callbacks_list'} = $callbacks_list; |
164
|
9
|
|
|
|
|
23
|
$authmilter->{'callbacks'} = $callbacks; |
165
|
9
|
|
|
|
|
36
|
$authmilter->{'count'} = $count; |
166
|
9
|
|
|
|
|
22
|
$authmilter->{'handler'} = $handler; |
167
|
9
|
|
|
|
|
30
|
$authmilter->{'object'} = $object; |
168
|
9
|
|
|
|
|
24
|
$authmilter->{'object_maker'} = $object_maker; |
169
|
|
|
|
|
|
|
|
170
|
9
|
|
|
|
|
43
|
$authmilter->setup_handlers(); |
171
|
|
|
|
|
|
|
|
172
|
9
|
|
|
|
|
30
|
$self->{ 'authmilter' } = $authmilter; |
173
|
|
|
|
|
|
|
|
174
|
9
|
|
|
|
|
43
|
$self->handler()->top_setup_callback(); |
175
|
|
|
|
|
|
|
|
176
|
9
|
|
|
|
|
99
|
$self->snapshot( '_new' ); |
177
|
|
|
|
|
|
|
|
178
|
9
|
|
|
|
|
65
|
return $self; |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
sub snapshot { |
182
|
9
|
|
|
9
|
1
|
27
|
my ( $self, $name ) = @_; |
183
|
9
|
|
|
|
|
1483
|
my $snapshot = clone( $self->{ 'authmilter' } ); |
184
|
9
|
|
|
|
|
71
|
$self->{ 'snapshots' }->{ $name } = $snapshot; |
185
|
9
|
|
|
|
|
21
|
return; |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
sub switch { |
189
|
146
|
|
|
146
|
1
|
1963
|
my ( $self, $name ) = @_; |
190
|
146
|
50
|
|
|
|
755
|
croak 'unknown snapshot' if ! exists ( $self->{ 'snapshots' }->{ $name } ); |
191
|
146
|
|
|
|
|
21675
|
my $snapshot = clone( $self->{ 'snapshots' }->{ $name } ); |
192
|
146
|
|
|
|
|
869
|
$self->{ 'authmilter' } = $snapshot; |
193
|
146
|
|
|
|
|
378
|
return; |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
sub handler { |
197
|
2130
|
|
|
2130
|
1
|
3706
|
my ( $self ) = @_; |
198
|
2130
|
|
|
|
|
17609
|
return $self->{ 'authmilter' }->{ 'handler' }->{ '_Handler' }; |
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
sub connect { ## no critic |
202
|
146
|
|
|
146
|
1
|
518
|
my ( $self, $name, $ip ) = @_; |
203
|
146
|
|
|
|
|
393
|
my $authmilter = $self->{ 'authmilter' }; |
204
|
146
|
|
50
|
|
|
315
|
my $ip_obj = eval{ Net::IP->new( $ip ) } // undef; |
|
146
|
|
|
|
|
1360
|
|
205
|
|
|
|
|
|
|
# An undef here should not make it through to handlers, however |
206
|
|
|
|
|
|
|
# for testing we will allow this. |
207
|
146
|
|
|
|
|
141286
|
return $self->handler()->top_connect_callback( $name, $ip_obj ); |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
sub helo { |
211
|
146
|
|
|
146
|
1
|
418
|
my ( $self, $helo ) = @_; |
212
|
146
|
|
|
|
|
389
|
return $self->handler()->top_helo_callback( $helo ); |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
sub mailfrom { |
216
|
146
|
|
|
146
|
1
|
462
|
my ( $self, $from ) = @_; |
217
|
146
|
|
|
|
|
394
|
return $self->handler()->top_envfrom_callback( $from ); |
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
sub rcptto { |
221
|
146
|
|
|
146
|
1
|
375
|
my ( $self, $to ) = @_; |
222
|
146
|
|
|
|
|
365
|
return $self->handler()->top_envrcpt_callback( $to ); |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
sub header { |
226
|
553
|
|
|
553
|
1
|
1279
|
my ( $self, $key, $value, $original ) = @_; |
227
|
553
|
50
|
|
|
|
1592
|
$original = "$key: $value" if ! defined $original; |
228
|
553
|
|
|
|
|
1156
|
return $self->handler()->top_header_callback( $key, $value, $original ); |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
sub end_of_headers { |
232
|
146
|
|
|
146
|
1
|
341
|
my ( $self ) = @_; |
233
|
146
|
|
|
|
|
393
|
return $self->handler()->top_eoh_callback(); |
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
sub body { |
237
|
146
|
|
|
146
|
1
|
427
|
my ( $self, $body ) = @_; |
238
|
146
|
|
|
|
|
468
|
return $self->handler()->top_body_callback( $body ); |
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
sub end_of_message { |
242
|
146
|
|
|
146
|
1
|
352
|
my ( $self ) = @_; |
243
|
146
|
|
|
|
|
435
|
return $self->handler()->top_eom_callback(); |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
sub close { ## no critic |
247
|
12
|
|
|
12
|
1
|
36584
|
my ( $self ) = @_; |
248
|
12
|
|
|
|
|
47
|
return $self->handler()->top_close_callback(); |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
sub abort { |
252
|
0
|
|
|
0
|
1
|
0
|
my ( $self ) = @_; |
253
|
0
|
|
|
|
|
0
|
return $self->handler()->top_abort_callback(); |
254
|
|
|
|
|
|
|
} |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
sub addheader { |
257
|
145
|
|
|
145
|
1
|
335
|
my ( $self ) = @_; |
258
|
145
|
|
|
|
|
417
|
return $self->handler()->top_addheader_callback(); |
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
sub run { |
262
|
145
|
|
|
145
|
1
|
2024251
|
my ( $self, $args ) = @_; |
263
|
|
|
|
|
|
|
|
264
|
145
|
|
|
|
|
844
|
$self->switch( '_new' ); |
265
|
|
|
|
|
|
|
|
266
|
145
|
|
|
|
|
283
|
my $returncode; |
267
|
145
|
|
|
|
|
651
|
$returncode = $self->connect( $args->{ 'connect_name' }, $args->{ 'connect_ip' } ); |
268
|
145
|
50
|
|
|
|
476
|
die 'connect' if ( $returncode != SMFIS_CONTINUE ); |
269
|
145
|
|
|
|
|
522
|
$returncode = $self->helo( $args->{ 'helo' } ); |
270
|
145
|
50
|
|
|
|
442
|
die 'helo' if ( $returncode != SMFIS_CONTINUE ); |
271
|
145
|
|
|
|
|
631
|
$returncode = $self->mailfrom( $args->{ 'mailfrom' } ); |
272
|
145
|
50
|
|
|
|
564
|
die 'mailfrom' if ( $returncode != SMFIS_CONTINUE ); |
273
|
145
|
|
|
|
|
282
|
foreach my $rcptto ( @{ $args->{ 'rcptto' } } ) { |
|
145
|
|
|
|
|
497
|
|
274
|
145
|
|
|
|
|
525
|
$returncode = $self->rcptto( $rcptto ); |
275
|
145
|
50
|
|
|
|
593
|
die 'rcptto ' . $rcptto if ( $returncode != SMFIS_CONTINUE ); |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
|
278
|
145
|
|
|
|
|
416
|
my $body = $args->{ 'body' }; |
279
|
145
|
|
|
|
|
2037
|
$body =~ s/\r?\n/\n/g; |
280
|
|
|
|
|
|
|
|
281
|
145
|
|
|
|
|
885
|
my @lines = split( /\n/, $body ); |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
# Process headers |
284
|
145
|
|
|
|
|
346
|
my $buffer = q{}; |
285
|
145
|
|
|
|
|
531
|
while ( my $line = shift @lines ) { |
286
|
1167
|
|
|
|
|
1687
|
chomp $line; |
287
|
1167
|
50
|
|
|
|
2045
|
last if $line eq q{}; |
288
|
|
|
|
|
|
|
|
289
|
1167
|
100
|
|
|
|
2941
|
if ( $line =~ /^\s/ ) { |
290
|
616
|
|
|
|
|
1357
|
$buffer .= "\n" . $line; |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
else { |
293
|
551
|
100
|
|
|
|
1125
|
if ( $buffer ) { |
294
|
406
|
|
|
|
|
1500
|
my ( $key, $value ) = split( ':', $buffer, 2 ); |
295
|
406
|
|
|
|
|
1059
|
$key =~ s/\s+$//; |
296
|
406
|
|
|
|
|
1514
|
$value =~ s/^\s+//; |
297
|
406
|
|
|
|
|
1185
|
$returncode = $self->header( $key, $value ); |
298
|
406
|
50
|
|
|
|
1073
|
die "header $key: $value" if ( $returncode != SMFIS_CONTINUE ); |
299
|
|
|
|
|
|
|
} |
300
|
551
|
|
|
|
|
1888
|
$buffer = $line; |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
} |
304
|
145
|
50
|
|
|
|
457
|
if ( $buffer ) { |
305
|
145
|
|
|
|
|
639
|
my ( $key, $value ) = split( ':', $buffer, 2 ); |
306
|
145
|
|
|
|
|
532
|
$key =~ s/\s+$//; |
307
|
145
|
|
|
|
|
718
|
$value =~ s/^\s+//; |
308
|
145
|
|
|
|
|
460
|
$returncode = $self->header( $key, $value ); |
309
|
145
|
50
|
|
|
|
469
|
die "header $key: $value" if ( $returncode != SMFIS_CONTINUE ); |
310
|
|
|
|
|
|
|
} |
311
|
|
|
|
|
|
|
|
312
|
145
|
|
|
|
|
485
|
$returncode = $self->end_of_headers(); |
313
|
145
|
50
|
|
|
|
551
|
die 'eoh' if ( $returncode != SMFIS_CONTINUE ); |
314
|
|
|
|
|
|
|
|
315
|
145
|
|
|
|
|
1009
|
$returncode = $self->body( join( "\n", @lines) . "\n" ); |
316
|
145
|
50
|
|
|
|
493
|
die 'body' if ( $returncode != SMFIS_CONTINUE ); |
317
|
|
|
|
|
|
|
|
318
|
145
|
|
|
|
|
498
|
$returncode = $self->end_of_message(); |
319
|
145
|
50
|
|
|
|
507
|
die 'body' if ( $returncode != SMFIS_CONTINUE ); |
320
|
|
|
|
|
|
|
|
321
|
145
|
|
|
|
|
615
|
$self->addheader(); |
322
|
|
|
|
|
|
|
# $self->close(); |
323
|
|
|
|
|
|
|
|
324
|
145
|
|
|
|
|
643
|
return; |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
sub get_return { |
328
|
0
|
|
|
0
|
1
|
0
|
my ( $self ) = @_; |
329
|
0
|
|
|
|
|
0
|
return $self->handler()->get_return(); |
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
sub get_reject_mail { |
333
|
0
|
|
|
0
|
1
|
0
|
my ( $self ) = @_; |
334
|
0
|
|
|
|
|
0
|
return $self->handler()->get_reject_mail(); |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
sub servername { |
338
|
194
|
|
|
194
|
1
|
2802
|
my ( $self ) = @_; |
339
|
194
|
|
|
|
|
634
|
return 'handlertester.test.authmilter.org'; |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
sub get_authresults_header { |
343
|
194
|
|
|
194
|
1
|
60691
|
my ( $self ) = @_; |
344
|
|
|
|
|
|
|
# Build a Mail::AuthenticationReslts object |
345
|
194
|
|
100
|
|
|
612
|
my $c_auth_headers = clone( $self->handler()->{ 'c_auth_headers'} ) // []; |
346
|
194
|
|
100
|
|
|
655
|
my $auth_headers = clone( $self->handler()->{ 'auth_headers'} ) // []; |
347
|
194
|
|
|
|
|
632
|
my @added_ar_headers = ( @{ $c_auth_headers }, @{ $auth_headers } ); |
|
194
|
|
|
|
|
397
|
|
|
194
|
|
|
|
|
474
|
|
348
|
194
|
|
|
|
|
936
|
my $header = Mail::AuthenticationResults::Header->new()->set_value( Mail::AuthenticationResults::Header::AuthServID->new()->set_value( $self->servername() ) ); |
349
|
194
|
|
|
|
|
5912
|
foreach my $ar_header ( @added_ar_headers ) { |
350
|
335
|
|
|
|
|
6332
|
eval{ $ar_header->orphan(); }; # Remove parent for testing. |
|
335
|
|
|
|
|
912
|
|
351
|
335
|
|
|
|
|
2713
|
$header->add_child( $ar_header ); |
352
|
|
|
|
|
|
|
} |
353
|
194
|
|
|
|
|
7656
|
return $header; |
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
1; |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
__END__ |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
=pod |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
=encoding UTF-8 |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
=head1 NAME |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
Mail::Milter::Authentication::Tester::HandlerTester |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
=head1 VERSION |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
version 20191206 |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
=head1 SYNOPSIS |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
Emulates an Authentication Milter environment with methods for testing Handlers. |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
Can snapshot and restore state at any point. |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
=head1 DESCRIPTION |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
Make testing of Authentication Milter Handler modules easier. |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
=head1 NAME |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
Mail::Milter::Authentication::Tester::HandlerTester - Test harness for testing Authentication Milter Handlers |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
=head1 CONSTRUCTOR |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
=over |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
=item new( $args ) |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
Instantiate a new HandlerTester object. |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
$args is a hashref with the following entries. |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
=over |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
=item prefix |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
Required |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
The Prefix path containing the authentication milter config file(s). This should contain |
403
|
|
|
|
|
|
|
all configuration files required for your test, the main authentication_milter.json file |
404
|
|
|
|
|
|
|
can be overridden by the handler_config option (see below). |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
This location should, for example, contain a valid mail-dmarc.ini for any tests using |
407
|
|
|
|
|
|
|
the DMARC handler. |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
=item handler_config |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
If present, the config will be built from a generic default SMTP environment, with the given |
412
|
|
|
|
|
|
|
HASHREF substituted as the Handler configuration. This eliminates the need to have a config file |
413
|
|
|
|
|
|
|
for each handler configuration you wish to test. |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
=item zonedata |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
The zonefile data for use with Net::DNS::Resolver::Mock |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
=item zonefile |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
A zonefile for use with Net::DNS::Resolver::Mock |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
=back |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
=back |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
=head1 METHODS |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
=over |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
=item snapshot( $name ) |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
Save a snapshot with the given name |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
=item switch( $name ) |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
Restore state from the given snapshot |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
=item handler() |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
Returns the Handler object |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
=item connect( $name, $ip ) |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
Call the connect callbacks with the given data. |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
Returns the value of get_return() |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
=item helo( $name ) |
450
|
|
|
|
|
|
|
|
451
|
|
|
|
|
|
|
Call the helo callbacks with the given data. |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
Returns the value of get_return(); |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
=item mailfrom( $email ) |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
Call the envfrom callbacks with the given data. |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
Returns the value of get_return(); |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
=item rcptto( $email ) |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
Call the envrcpt callbacks with the given data. |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
Returns the value of get_return(); |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
=item header( $key, $value ) |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
Call the header callbacks with the given data. |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
Returns the value of get_return() |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
=item end_of_headers() |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
Call the end_of_headers callbacks. |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
Returns the value of get_return() |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
=item body( $body_chunk ) |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
Call the body callbacks with the given data. |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
Returns the value of get_return() |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
=item end_of_message() |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
Call the eom callbacks. |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
Returns the value of get_return() |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
=item close() |
492
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
Call the close callbacks. |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
Returns the value of get_return() |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
=item abort() |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
Call the abort callbacks. |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
=item addheader() |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
Call the addheader callbacks. |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
=item run( $args ) |
506
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
Run with a given set of data as defined in $args hashref. |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
Dies if the mail would be rejected. |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
Arguments of $args are. |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
=over |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
=item connect_name |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
The name of the connecting server. |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
=item connect_ip |
520
|
|
|
|
|
|
|
|
521
|
|
|
|
|
|
|
The ip address of the connecting server. |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
=item helo |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
The helo string. |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
=item mailfrom |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
The envelope MAILFROM address. |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
=item rcptto |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
Arrayref of the envelope RCPTTO addresses. |
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
=item body |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
The email body. |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
=back |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
=item get_return() |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
Returns the value of get_return() from the current handler object. |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
=item get_reject_mail() |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
Returns the value of get_reject_mail() from the current handler object. |
548
|
|
|
|
|
|
|
|
549
|
|
|
|
|
|
|
=item servername() |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
Returns a dummy authservid servername. |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
=item get_authresults_header() |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
Returns a Mail::AuthenticationResults::Header object representing the authentication results |
556
|
|
|
|
|
|
|
header which would be added to the message. |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
=back |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
=head1 DEPENDENCIES |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
Carp |
563
|
|
|
|
|
|
|
Clone |
564
|
|
|
|
|
|
|
Mail::AuthenticationResults::Header |
565
|
|
|
|
|
|
|
Mail::AuthenticationResults::Header::AuthServID |
566
|
|
|
|
|
|
|
Mail::Milter::Authentication |
567
|
|
|
|
|
|
|
Mail::Milter::Authentication::Protocol::Milter |
568
|
|
|
|
|
|
|
Mail::Milter::Authentication::Protocol::SMTP |
569
|
|
|
|
|
|
|
Mail::Milter::Authentication::Config |
570
|
|
|
|
|
|
|
Module::Load |
571
|
|
|
|
|
|
|
Net::DNS::Resolver::Mock |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
=head1 AUTHORS |
574
|
|
|
|
|
|
|
|
575
|
|
|
|
|
|
|
Marc Bradshaw E<lt>marc@marcbradshaw.netE<gt> |
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
=head1 COPYRIGHT |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
Copyright 2018 |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
This library is free software; you may redistribute it and/or |
582
|
|
|
|
|
|
|
modify it under the same terms as Perl itself. |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
=head1 AUTHOR |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
Marc Bradshaw <marc@marcbradshaw.net> |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
This software is copyright (c) 2018 by Marc Bradshaw. |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
593
|
|
|
|
|
|
|
the same terms as the Perl 5 programming language system itself. |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
=cut |