← Index
NYTProf Performance Profile   « line view »
For /usr/local/bin/sa-learn
  Run on Sun Nov 5 02:36:06 2017
Reported on Sun Nov 5 02:56:22 2017

Filename/usr/local/lib/perl5/site_perl/Mail/SpamAssassin/Plugin/WLBLEval.pm
StatementsExecuted 37 statements in 5.92ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
111285µs767µsMail::SpamAssassin::Plugin::WLBLEval::::newMail::SpamAssassin::Plugin::WLBLEval::new
11150µs58µsMail::SpamAssassin::Plugin::WLBLEval::::BEGIN@23Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@23
11147µs47µsMail::SpamAssassin::Plugin::WLBLEval::::BEGIN@20Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@20
11142µs109µsMail::SpamAssassin::Plugin::WLBLEval::::BEGIN@26Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@26
11135µs70µsMail::SpamAssassin::Plugin::WLBLEval::::BEGIN@24Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@24
11130µs190µsMail::SpamAssassin::Plugin::WLBLEval::::BEGIN@21Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@21
11128µs33µsMail::SpamAssassin::Plugin::WLBLEval::::BEGIN@25Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@25
11124µs93µsMail::SpamAssassin::Plugin::WLBLEval::::BEGIN@28Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@28
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::_check_addr_matches_rcvdMail::SpamAssassin::Plugin::WLBLEval::_check_addr_matches_rcvd
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::_check_from_in_default_whitelistMail::SpamAssassin::Plugin::WLBLEval::_check_from_in_default_whitelist
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::_check_from_in_whitelistMail::SpamAssassin::Plugin::WLBLEval::_check_from_in_whitelist
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::_check_uri_host_listedMail::SpamAssassin::Plugin::WLBLEval::_check_uri_host_listed
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::_check_whitelistMail::SpamAssassin::Plugin::WLBLEval::_check_whitelist
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::_check_whitelist_rcvdMail::SpamAssassin::Plugin::WLBLEval::_check_whitelist_rcvd
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::check_forged_in_default_whitelistMail::SpamAssassin::Plugin::WLBLEval::check_forged_in_default_whitelist
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::check_forged_in_whitelistMail::SpamAssassin::Plugin::WLBLEval::check_forged_in_whitelist
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::check_from_in_blacklistMail::SpamAssassin::Plugin::WLBLEval::check_from_in_blacklist
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::check_from_in_default_whitelistMail::SpamAssassin::Plugin::WLBLEval::check_from_in_default_whitelist
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::check_from_in_listMail::SpamAssassin::Plugin::WLBLEval::check_from_in_list
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::check_from_in_whitelistMail::SpamAssassin::Plugin::WLBLEval::check_from_in_whitelist
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::check_mailfrom_matches_rcvdMail::SpamAssassin::Plugin::WLBLEval::check_mailfrom_matches_rcvd
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::check_to_in_all_spamMail::SpamAssassin::Plugin::WLBLEval::check_to_in_all_spam
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::check_to_in_blacklistMail::SpamAssassin::Plugin::WLBLEval::check_to_in_blacklist
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::check_to_in_listMail::SpamAssassin::Plugin::WLBLEval::check_to_in_list
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::check_to_in_more_spamMail::SpamAssassin::Plugin::WLBLEval::check_to_in_more_spam
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::check_to_in_whitelistMail::SpamAssassin::Plugin::WLBLEval::check_to_in_whitelist
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::check_uri_host_in_blacklistMail::SpamAssassin::Plugin::WLBLEval::check_uri_host_in_blacklist
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::check_uri_host_in_whitelistMail::SpamAssassin::Plugin::WLBLEval::check_uri_host_in_whitelist
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::check_uri_host_listedMail::SpamAssassin::Plugin::WLBLEval::check_uri_host_listed
0000s0sMail::SpamAssassin::Plugin::WLBLEval::::check_wb_listMail::SpamAssassin::Plugin::WLBLEval::check_wb_list
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1# <@LICENSE>
2# Licensed to the Apache Software Foundation (ASF) under one or more
3# contributor license agreements. See the NOTICE file distributed with
4# this work for additional information regarding copyright ownership.
5# The ASF licenses this file to you under the Apache License, Version 2.0
6# (the "License"); you may not use this file except in compliance with
7# the License. You may obtain a copy of the License at:
8#
9# http://www.apache.org/licenses/LICENSE-2.0
10#
11# Unless required by applicable law or agreed to in writing, software
12# distributed under the License is distributed on an "AS IS" BASIS,
13# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14# See the License for the specific language governing permissions and
15# limitations under the License.
16# </@LICENSE>
17
18package Mail::SpamAssassin::Plugin::WLBLEval;
19
20271µs147µs
# spent 47µs within Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@20 which was called: # once (47µs+0s) by Mail::SpamAssassin::PluginHandler::load_plugin at line 20
use Mail::SpamAssassin::Plugin;
# spent 47µs making 1 call to Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@20
212112µs2351µs
# spent 190µs (30+161) within Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@21 which was called: # once (30µs+161µs) by Mail::SpamAssassin::PluginHandler::load_plugin at line 21
use Mail::SpamAssassin::Logger;
# spent 190µs making 1 call to Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@21 # spent 161µs making 1 call to Exporter::import
22
23282µs267µs
# spent 58µs (50+9) within Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@23 which was called: # once (50µs+9µs) by Mail::SpamAssassin::PluginHandler::load_plugin at line 23
use strict;
# spent 58µs making 1 call to Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@23 # spent 9µs making 1 call to strict::import
24266µs2105µs
# spent 70µs (35+35) within Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@24 which was called: # once (35µs+35µs) by Mail::SpamAssassin::PluginHandler::load_plugin at line 24
use warnings;
# spent 70µs making 1 call to Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@24 # spent 35µs making 1 call to warnings::import
25280µs239µs
# spent 33µs (28+5) within Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@25 which was called: # once (28µs+5µs) by Mail::SpamAssassin::PluginHandler::load_plugin at line 25
use bytes;
# spent 33µs making 1 call to Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@25 # spent 5µs making 1 call to bytes::import
26284µs2176µs
# spent 109µs (42+67) within Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@26 which was called: # once (42µs+67µs) by Mail::SpamAssassin::PluginHandler::load_plugin at line 26
use re 'taint';
# spent 109µs making 1 call to Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@26 # spent 67µs making 1 call to re::import
27
2825.25ms2162µs
# spent 93µs (24+69) within Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@28 which was called: # once (24µs+69µs) by Mail::SpamAssassin::PluginHandler::load_plugin at line 28
use vars qw(@ISA);
# spent 93µs making 1 call to Mail::SpamAssassin::Plugin::WLBLEval::BEGIN@28 # spent 69µs making 1 call to vars::import
29114µs@ISA = qw(Mail::SpamAssassin::Plugin);
30
31# constructor: register the eval rule
32
# spent 767µs (285+482) within Mail::SpamAssassin::Plugin::WLBLEval::new which was called: # once (285µs+482µs) by Mail::SpamAssassin::PluginHandler::load_plugin at line 1 of (eval 105)[Mail/SpamAssassin/PluginHandler.pm:129]
sub new {
3312µs my $class = shift;
3418µs my $mailsaobject = shift;
35
36 # some boilerplate...
3712µs $class = ref($class) || $class;
38117µs119µs my $self = $class->SUPER::new($mailsaobject);
# spent 19µs making 1 call to Mail::SpamAssassin::Plugin::new
3912µs bless ($self, $class);
40
41 # the important bit!
42112µs139µs $self->register_eval_rule("check_from_in_blacklist");
# spent 39µs making 1 call to Mail::SpamAssassin::Plugin::register_eval_rule
4316µs127µs $self->register_eval_rule("check_to_in_blacklist");
# spent 27µs making 1 call to Mail::SpamAssassin::Plugin::register_eval_rule
4416µs128µs $self->register_eval_rule("check_to_in_whitelist");
# spent 28µs making 1 call to Mail::SpamAssassin::Plugin::register_eval_rule
4516µs128µs $self->register_eval_rule("check_to_in_more_spam");
# spent 28µs making 1 call to Mail::SpamAssassin::Plugin::register_eval_rule
4616µs127µs $self->register_eval_rule("check_to_in_all_spam");
# spent 27µs making 1 call to Mail::SpamAssassin::Plugin::register_eval_rule
4716µs130µs $self->register_eval_rule("check_from_in_list");
# spent 30µs making 1 call to Mail::SpamAssassin::Plugin::register_eval_rule
4816µs128µs $self->register_eval_rule("check_to_in_list");
# spent 28µs making 1 call to Mail::SpamAssassin::Plugin::register_eval_rule
4916µs126µs $self->register_eval_rule("check_from_in_whitelist");
# spent 26µs making 1 call to Mail::SpamAssassin::Plugin::register_eval_rule
5016µs131µs $self->register_eval_rule("check_forged_in_whitelist");
# spent 31µs making 1 call to Mail::SpamAssassin::Plugin::register_eval_rule
5116µs156µs $self->register_eval_rule("check_from_in_default_whitelist");
# spent 56µs making 1 call to Mail::SpamAssassin::Plugin::register_eval_rule
5216µs129µs $self->register_eval_rule("check_forged_in_default_whitelist");
# spent 29µs making 1 call to Mail::SpamAssassin::Plugin::register_eval_rule
5316µs130µs $self->register_eval_rule("check_mailfrom_matches_rcvd");
# spent 30µs making 1 call to Mail::SpamAssassin::Plugin::register_eval_rule
5416µs128µs $self->register_eval_rule("check_uri_host_listed");
# spent 28µs making 1 call to Mail::SpamAssassin::Plugin::register_eval_rule
55 # same as: eval:check_uri_host_listed('BLACK') :
5616µs128µs $self->register_eval_rule("check_uri_host_in_blacklist");
# spent 28µs making 1 call to Mail::SpamAssassin::Plugin::register_eval_rule
57 # same as: eval:check_uri_host_listed('WHITE') :
5816µs128µs $self->register_eval_rule("check_uri_host_in_whitelist");
# spent 28µs making 1 call to Mail::SpamAssassin::Plugin::register_eval_rule
59
60121µs return $self;
61}
62
63sub check_from_in_blacklist {
64 my ($self, $pms) = @_;
65 foreach ($pms->all_from_addrs()) {
66 if ($self->_check_whitelist ($self->{main}->{conf}->{blacklist_from}, $_)) {
67 return 1;
68 }
69 }
70}
71
72sub check_to_in_blacklist {
73 my ($self, $pms) = @_;
74 foreach ($pms->all_to_addrs()) {
75 if ($self->_check_whitelist ($self->{main}->{conf}->{blacklist_to}, $_)) {
76 return 1;
77 }
78 }
79}
80
81sub check_to_in_whitelist {
82 my ($self, $pms) = @_;
83 foreach ($pms->all_to_addrs()) {
84 if ($self->_check_whitelist ($self->{main}->{conf}->{whitelist_to}, $_)) {
85 return 1;
86 }
87 }
88}
89
90sub check_to_in_more_spam {
91 my ($self, $pms) = @_;
92 foreach ($pms->all_to_addrs()) {
93 if ($self->_check_whitelist ($self->{main}->{conf}->{more_spam_to}, $_)) {
94 return 1;
95 }
96 }
97}
98
99sub check_to_in_all_spam {
100 my ($self, $pms) = @_;
101 foreach ($pms->all_to_addrs()) {
102 if ($self->_check_whitelist ($self->{main}->{conf}->{all_spam_to}, $_)) {
103 return 1;
104 }
105 }
106}
107
108sub check_from_in_list {
109 my ($self, $pms, $list) = @_;
110 my $list_ref = $self->{main}{conf}{$list};
111 unless (defined $list_ref) {
112 warn "eval: could not find list $list";
113 return;
114 }
115
116 foreach my $addr ($pms->all_from_addrs()) {
117 if ($self->_check_whitelist ($list_ref, $addr)) {
118 return 1;
119 }
120 }
121
122 return 0;
123}
124
125# TODO: this should be moved to a utility module off PerMsgStatus,
126# rather than a plugin API; it's used in Bayes.pm as a utility
127sub check_wb_list {
128 my ($self, $params) = @_;
129
130 return unless (defined $params->{permsgstatus});
131 return unless (defined $params->{type});
132 return unless (defined $params->{list});
133
134 if (lc $params->{type} eq "to") {
135 return $self->check_to_in_list($params->{permsgstatus}, $params->{list});
136 }
137 elsif (lc $params->{type} eq "from") {
138 return $self->check_from_in_list($params->{permsgstatus}, $params->{list});
139 }
140
141 return;
142}
143
144sub check_to_in_list {
145 my ($self,$pms,$list) = @_;
146 my $list_ref = $self->{main}{conf}{$list};
147 unless (defined $list_ref) {
148 warn "eval: could not find list $list";
149 return;
150 }
151
152 foreach my $addr ($pms->all_to_addrs()) {
153 if ($self->_check_whitelist ($list_ref, $addr)) {
154 return 1;
155 }
156 }
157
158 return 0;
159}
160
161###########################################################################
162
163sub check_from_in_whitelist {
164 my ($self, $pms) = @_;
165 $self->_check_from_in_whitelist($pms) unless exists $pms->{from_in_whitelist};
166 return ($pms->{from_in_whitelist} > 0);
167}
168
169sub check_forged_in_whitelist {
170 my ($self, $pms) = @_;
171 $self->_check_from_in_whitelist($pms) unless exists $pms->{from_in_whitelist};
172 $self->_check_from_in_default_whitelist($pms) unless exists $pms->{from_in_default_whitelist};
173 return ($pms->{from_in_whitelist} < 0) && ($pms->{from_in_default_whitelist} == 0);
174}
175
176sub check_from_in_default_whitelist {
177 my ($self, $pms) = @_;
178 $self->_check_from_in_default_whitelist($pms) unless exists $pms->{from_in_default_whitelist};
179 return ($pms->{from_in_default_whitelist} > 0);
180}
181
182sub check_forged_in_default_whitelist {
183 my ($self, $pms) = @_;
184 $self->_check_from_in_default_whitelist($pms) unless exists $pms->{from_in_default_whitelist};
185 $self->_check_from_in_whitelist($pms) unless exists $pms->{from_in_whitelist};
186 return ($pms->{from_in_default_whitelist} < 0) && ($pms->{from_in_whitelist} == 0);
187}
188
189###########################################################################
190
191sub _check_from_in_whitelist {
192 my ($self, $pms) = @_;
193 my $found_match = 0;
194 foreach ($pms->all_from_addrs()) {
195 if ($self->_check_whitelist ($self->{main}->{conf}->{whitelist_from}, $_)) {
196 $pms->{from_in_whitelist} = 1;
197 return;
198 }
199 my $wh = $self->_check_whitelist_rcvd ($pms, $self->{main}->{conf}->{whitelist_from_rcvd}, $_);
200 if ($wh == 1) {
201 $pms->{from_in_whitelist} = 1;
202 return;
203 }
204 elsif ($wh == -1) {
205 $found_match = -1;
206 }
207 }
208
209 $pms->{from_in_whitelist} = $found_match;
210 return;
211}
212
213###########################################################################
214
215sub _check_from_in_default_whitelist {
216 my ($self, $pms) = @_;
217 my $found_match = 0;
218 foreach ($pms->all_from_addrs()) {
219 my $wh = $self->_check_whitelist_rcvd ($pms, $self->{main}->{conf}->{def_whitelist_from_rcvd}, $_);
220 if ($wh == 1) {
221 $pms->{from_in_default_whitelist} = 1;
222 return;
223 }
224 elsif ($wh == -1) {
225 $found_match = -1;
226 }
227 }
228
229 $pms->{from_in_default_whitelist} = $found_match;
230 return;
231}
232
233###########################################################################
234
235# check if domain name of an envelope sender address matches a domain name
236# of the first untrusted relay (if any), or any trusted relay otherwise
237sub check_mailfrom_matches_rcvd {
238 my ($self, $pms) = @_;
239 my $sender = $pms->get("EnvelopeFrom:addr");
240 return 0 if $sender eq '';
241 return $self->_check_addr_matches_rcvd($pms,$sender);
242}
243
244# check if domain name of a supplied e-mail address matches a domain name
245# of the first untrusted relay (if any), or any trusted relay otherwise
246sub _check_addr_matches_rcvd {
247 my ($self, $pms, $addr) = @_;
248
249 local $1;
250 return 0 if $addr !~ / \@ ( [^\@]+ \. [^\@]+ ) \z/x;
251 my $addr_domain = lc $1;
252
253 my @relays;
254 if ($pms->{num_relays_untrusted} > 0) {
255 # check against the first untrusted, if present
256 @relays = $pms->{relays_untrusted}->[0];
257 } elsif ($pms->{num_relays_trusted} > 0) {
258 # otherwise try all trusted ones, but only do so
259 # if there are no untrusted relays to avoid forgery
260 push(@relays, @{$pms->{relays_trusted}});
261 }
262 return 0 if !@relays;
263
264 my($adrh,$adrd) =
265 $self->{main}->{registryboundaries}->split_domain($addr_domain);
266 my $match = 0;
267 my $any_tried = 0;
268 foreach my $rly (@relays) {
269 my $relay_rdns = $rly->{lc_rdns};
270 next if !defined $relay_rdns || $relay_rdns eq '';
271 my($rlyh,$rlyd) =
272 $self->{main}->{registryboundaries}->split_domain($relay_rdns);
273 $any_tried = 1;
274 if ($adrd eq $rlyd) {
275 dbg("rules: $addr MATCHES relay $relay_rdns ($adrd)");
276 $match = 1; last;
277 }
278 }
279 if ($any_tried && !$match) {
280 dbg("rules: %s does NOT match relay(s) %s",
281 $addr, join(', ', map { $_->{lc_rdns} } @relays));
282 }
283 return $match;
284}
285
286###########################################################################
287
288# look up $addr and trusted relays in a whitelist with rcvd
289# note if it appears to be a forgery and $addr is not in any-relay list
290sub _check_whitelist_rcvd {
291 my ($self, $pms, $list, $addr) = @_;
292
293 # we can only match this if we have at least 1 trusted or untrusted header
294 return 0 unless ($pms->{num_relays_untrusted}+$pms->{num_relays_trusted} > 0);
295
296 my @relays;
297 # try the untrusted one first
298 if ($pms->{num_relays_untrusted} > 0) {
299 @relays = $pms->{relays_untrusted}->[0];
300 }
301 # then try the trusted ones; the user could have whitelisted a trusted
302 # relay, totally permitted
303 # but do not do this if any untrusted relays, to avoid forgery -- bug 4425
304 if ($pms->{num_relays_trusted} > 0 && !$pms->{num_relays_untrusted} ) {
305 push (@relays, @{$pms->{relays_trusted}});
306 }
307
308 $addr = lc $addr;
309 my $found_forged = 0;
310 foreach my $white_addr (keys %{$list}) {
311 my $regexp = qr/$list->{$white_addr}{re}/i;
312 foreach my $domain (@{$list->{$white_addr}{domain}}) {
313
314 if ($addr =~ $regexp) {
315 my $match;
316 foreach my $lastunt (@relays) {
317 local $1;
318 if ($domain =~ m{^ \[ (.*) \] \z}sx) { # matching by IP address
319 my($wl_ip, $rly_ip) = ($1, $lastunt->{ip});
320 if (!defined $rly_ip || $rly_ip eq '') {
321 # relay's IP address not provided or unparseable
322 } elsif ($wl_ip =~ /^\d+\.\d+\.\d+\.\d+\z/) {
323 if ($wl_ip eq $rly_ip) { $match = 1; last } # exact match
324 } elsif ($wl_ip =~ /^[\d\.]+\z/) { # assume IPv4 classful subnet
325 $wl_ip =~ s/\.*\z/./; # enforce trailing dot
326 if ($rly_ip =~ /^\Q$wl_ip\E/i) { $match = 1; last } # subnet
327 }
328 # todo: handle IPv6 and CIDR notation
329 } else { # match by a rdns name
330 my $rdns = $lastunt->{lc_rdns};
331 if ($rdns =~ /(?:^|\.)\Q${domain}\E$/i) { $match=1; last }
332 }
333 }
334 if ($match) {
335 dbg("rules: address %s matches (def_)whitelist_from_rcvd %s %s",
336 $addr, $list->{$white_addr}{re}, $domain);
337 return 1;
338 }
339 # found address match but no relay match. note as possible forgery
340 $found_forged = -1;
341 }
342 }
343 }
344 if ($found_forged) { # might be forgery. check if in list of exempted
345 my $wlist = $self->{main}->{conf}->{whitelist_allows_relays};
346 foreach my $fuzzy_addr (values %{$wlist}) {
347 if ($addr =~ /$fuzzy_addr/i) {
348 $found_forged = 0;
349 last;
350 }
351 }
352 }
353 return $found_forged;
354}
355
356###########################################################################
357
358sub _check_whitelist {
359 my ($self, $list, $addr) = @_;
360 $addr = lc $addr;
361 if (defined ($list->{$addr})) { return 1; }
362 study $addr; # study is a no-op since perl 5.16.0, eliminating related bugs
363 foreach my $regexp (values %{$list}) {
364 if ($addr =~ qr/$regexp/i) {
365 dbg("rules: address $addr matches whitelist or blacklist regexp: $regexp");
366 return 1;
367 }
368 }
369
370 return 0;
371}
372
373###########################################################################
374
375sub check_uri_host_in_blacklist {
376 my ($self, $pms) = @_;
377 $self->check_uri_host_listed($pms, 'BLACK');
378}
379
380sub check_uri_host_in_whitelist {
381 my ($self, $pms) = @_;
382 $self->check_uri_host_listed($pms, 'WHITE');
383}
384
385sub check_uri_host_listed {
386 my ($self, $pms, $subname) = @_;
387 my $host_enlisted_ref = $self->_check_uri_host_listed($pms);
388 if ($host_enlisted_ref) {
389 my $matched_host = $host_enlisted_ref->{$subname};
390 if ($matched_host) {
391 dbg("rules: uri host enlisted (%s): %s", $subname, $matched_host);
392 $pms->test_log("URI: $matched_host");
393 return 1;
394 }
395 }
396 return 0;
397}
398
399sub _check_uri_host_listed {
400 my ($self, $pms) = @_;
401
402 if ($pms->{'uri_host_enlisted'}) {
403 return $pms->{'uri_host_enlisted'}; # just provide a cached result
404 }
405
406 my $uri_lists_href = $self->{main}{conf}{uri_host_lists};
407 if (!$uri_lists_href || !%$uri_lists_href) {
408 $pms->{'uri_host_enlisted'} = {}; # no URI host lists
409 return $pms->{'uri_host_enlisted'};
410 }
411
412 my %host_enlisted;
413 my @uri_listnames = sort keys %$uri_lists_href;
414 if (would_log("dbg","rules")) {
415 foreach my $nm (@uri_listnames) {
416 dbg("rules: check_uri_host_listed: (%s) %s",
417 $nm, join(', ', map { $uri_lists_href->{$nm}{$_} ? $_ : '!'.$_ }
418 sort keys %{$uri_lists_href->{$nm}}));
419 }
420 }
421 # obtain a complete list of html-parsed domains
422 my $uris = $pms->get_uri_detail_list();
423 my %seen;
424 while (my($uri,$info) = each %$uris) {
425 next if $uri =~ /^mailto:/i; # we may want to skip mailto: uris (?)
426 while (my($host,$domain) = each( %{$info->{hosts}} )) { # typically one
427 next if $seen{$host};
428 $seen{$host} = 1;
429 local($1,$2);
430 my @query_keys;
431 if ($host =~ /^\[(.*)\]\z/) { # looks like an address literal
432 @query_keys = ( $1 );
433 } elsif ($host =~ /^\d+\.\d+\.\d+\.\d+\z/) { # IPv4 address
434 @query_keys = ( $host );
435 } elsif ($host ne '') {
436 my($h) = $host;
437 for (;;) {
438 shift @query_keys if @query_keys > 10; # sanity limit, keep tail
439 push(@query_keys, $h); # sub.example.com, example.com, com
440 last if $h !~ s{^([^.]*)\.(.*)\z}{$2}s;
441 }
442 }
443 foreach my $nm (@uri_listnames) {
444 my $match;
445 my $verdict;
446 my $hash_nm_ref = $uri_lists_href->{$nm};
447 foreach my $q (@query_keys) {
448 $verdict = $hash_nm_ref->{$q};
449 if (defined $verdict) {
450 $match = $q eq $host ? $host : "$host ($q)";
451 $match = '!' if !$verdict;
452 last;
453 }
454 }
455 if (defined $verdict) {
456 $host_enlisted{$nm} = $match if $verdict;
457 dbg("rules: check_uri_host_listed %s, (%s): %s, search: %s",
458 $uri, $nm, $match, join(', ',@query_keys));
459 }
460 }
461 }
462 }
463 $pms->{'uri_host_enlisted'} = \%host_enlisted;
464 return $pms->{'uri_host_enlisted'};
465}
466
46719µs1;
Report produced by the NYTProf 6.04 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.