source: trunk/dnsbl/DNSBL.pm@ 103

Last change on this file since 103 was 103, checked in by Kris Deugau, 3 days ago

/trunk/dnsbl

Refine DB transaction behaviour around addblock() based on glitches found
using it in earnest in updated production.
  • Property svn:keywords set to Date Rev Author Id
File size: 20.2 KB
Line 
1# DNSBL
2# Functions for interacting with the DNSBL database
3##
4# $Id: DNSBL.pm 103 2025-09-24 17:00:12Z kdeugau $
5# Copyright 2009-2012,2014,2018,2025 Kris Deugau <kdeugau@deepnet.cx>
6#
7# This program is free software: you can redistribute it and/or modify
8# it under the terms of the GNU General Public License as published by
9# the Free Software Foundation, either version 3 of the License, or
10# (at your option) any later version.
11#
12# This program is distributed in the hope that it will be useful,
13# but WITHOUT ANY WARRANTY; without even the implied warranty of
14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15# GNU General Public License for more details.
16#
17# You should have received a copy of the GNU General Public License
18# along with this program. If not, see <http://www.gnu.org/licenses/>.
19##
20
21package DNSBL;
22
23use strict;
24use warnings;
25use Exporter;
26
27use DBI;
28use NetAddr::IP;
29
30use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
31
32$VERSION = 3.0;
33@ISA = qw(Exporter);
34@EXPORT_OK = qw( $dbh );
35
36@EXPORT = qw( $dbh );
37%EXPORT_TAGS = ( ALL => [qw(
38 )]
39 );
40
41## "constants"
42
43# w00t! somewhere along the line, by accident or intent, SA's
44# check_dnsbl_sub can now check up to 24 bits of an DNSBL return value!
45# 1 not available so we don't $self->shoot(foot)
46our %bitfields = (
47 # ip
48 ip => 2,
49 # "I'm a total spamming moron!" - per-IP only!
50 slist => 128,
51
52 # Block listings. Ordering for levels 0, 1, 2 not ideal due to evolution of code.
53 # Levels 3 and higher are more coherently ordered
54
55 # Automatically listed blocks based on IP counts
56 0 => 16,
57 1 => 8,
58 2 => 4,
59 3 => 4096,
60 4 => 32768,
61 5 => 262144,
62 6 => 2097152,
63
64 # Out-of-band
65 org0 => 32,
66 block0 => 64,
67 org1 => 256,
68 org2 => 512,
69 block1 => 1024,
70 block2 => 2048,
71 org3 => 8192,
72 block3 => 16384,
73 org4 => 65536,
74 block4 => 131072,
75 org5 => 524288,
76 block5 => 1048576,
77 org6 => 4194304,
78 block6 => 8388608,
79
80);
81
82# probably needs some tuning; even 7 hits in a /24 is a pretty small percentage
83# number of IPs in a block of the given masklength needed to have that block automatically listed
84# defaults: (overridden by entries in db:autolist)
85our %autolist = (
86 31 => 1,
87 30 => 1,
88 29 => 2,
89 28 => 3,
90 27 => 4,
91 26 => 5,
92 25 => 6,
93 24 => 7,
94 23 => 8,
95 22 => 10,
96 21 => 13,
97 20 => 16,
98 19 => 19,
99 18 => 22,
100 17 => 26,
101 16 => 30,
102 15 => 34,
103 14 => 38,
104 13 => 42,
105 12 => 46,
106 11 => 50,
107 10 => 54,
108 9 => 58,
109 8 => 62,
110 7 => 2**31,
111 6 => 2**31,
112 5 => 2**31,
113 4 => 2**31,
114 3 => 2**31,
115 2 => 2**31,
116 1 => 2**31,
117 0 => 2**31
118);
119
120# le sigh. constants for masklength iterationing
121our @howmany = (1,128,64,32,16,8,4,2,1,128,64,32,16,8,4,2,1,128,64,32,16,8,4,2,1,128,64,32,16,8,4,2);
122
123# hard max depth. There are not enough bits in a 32-bit IP in 127/8 for more than 7 sets of 3 block-level
124# flags, plus one for the IP, plus one for an "alternate" IP flag, plus reserving the least significant bit
125# as a "don't use this because Reasons"
126our $maxlvl = 6;
127
128# variables
129our $dbh;
130
131our $err;
132our $errstr = '';
133
134# basic object subs
135sub new {
136 my $this = shift;
137 my $class = ref($this) || $this;
138 my %args = @_;
139
140 # Prepopulate a basic config. Note some of these *will* cause errors if left unset.
141 my %defconfig = (
142 dbhost => "localhost",
143 dbname => "dnsbl",
144 dbuser => "dnsbl",
145 dbpass => "spambgone",
146 );
147
148 my %siteconfig;
149 my $dbhost;
150 my $dbname;
151 my $dbuser;
152 my $dbpass;
153 if (defined($args{configfile})) {
154 if (-e $args{configfile} && -f $args{configfile}) {
155 my $ret = eval `cat $args{configfile}`;
156 unless ($ret) {
157 if ($@) { $errstr = "couldn't parse $args{configfile}: $@\n"; return; }
158 if (!defined($ret)) { $errstr = "couldn't load $args{configfile}: $!\n"; return; }
159 if (!$ret) { $errstr = "couldn't load $args{configfile}\n"; return; }
160 }
161 # crossload legacy variables, but prefer new %siteconfig values
162 $siteconfig{dbhost} = $dbhost if !$siteconfig{dbhost} && $dbhost;
163 $siteconfig{dbname} = $dbname if !$siteconfig{dbname} && $dbname;
164 $siteconfig{dbuser} = $dbuser if !$siteconfig{dbuser} && $dbuser;
165 $siteconfig{dbpass} = $dbpass if !$siteconfig{dbpass} && $dbpass;
166 }
167 }
168
169 # Assemble the object. Apply configuration hashes in order of precedence.
170 my $self = {
171 # Hardcoded defaults
172 %defconfig,
173 # Default config file OR caller-specified one, loaded above
174 %siteconfig,
175 # Caller-specified arguments
176 %args
177 };
178 bless $self, $class;
179
180 return $self;
181} # new()
182
183sub DESTROY {
184 my $self = shift;
185 $self->dbclose() if $dbh;
186}
187
188# JIC someone wants to close the db but not finish the script
189sub dbclose {
190 $dbh->disconnect;
191}
192
193## specific object subs:
194
195sub connect {
196 my $self = shift;
197 # after jumping a HUUUGE number of PG versions, AutoCommit => 0 produced some bizarre bugs
198 $dbh = DBI->connect("DBI:Pg:host=$self->{dbhost};dbname=$self->{dbname}", $self->{dbuser}, $self->{dbpass}, {
199 AutoCommit => 1,
200 PrintError => 0
201 })
202 or die "database inaccessible: ".$DBI::errstr;
203 my $sth = $dbh->prepare("SELECT masklen,ipcount FROM autolist");
204 $sth->execute;
205 while (my ($masklen,$ipcount) = $sth->fetchrow_array) {
206 $autolist{$masklen} = $ipcount;
207 }
208 $sth = $dbh->prepare("SELECT key,value FROM misc");
209 $sth->execute;
210 while (my ($key,$value) = $sth->fetchrow_array) {
211 $self->{misc}{$key} = $value;
212 }
213 return $dbh;
214}
215
216
217## DNSBLDB::initexport()
218# Prepare a couple of statement handles for later processing in export(). Assists in ~3x speed increase.
219my $parsth;
220my $sthmoron;
221sub initexport {
222 $parsth = $dbh->prepare("SELECT count(i.ip),b.block,b.level,b.listme AS oobblock,o.listme AS ooborg ".
223 "FROM iplist i INNER JOIN blocks b ON i.parent = b.block INNER JOIN orgs o ON b.orgid = o.orgid ".
224 "WHERE b.block >>= ? ".
225 "GROUP BY b.block,b.level,b.listme,o.listme ORDER BY b.block");
226 $sthmoron = $dbh->prepare("SELECT ip,s4list,exclude FROM iplist WHERE parent = ?");
227}
228
229
230## DNSBL::ipexists()
231# return report count if the IP has been reported, otherwise return undef
232sub ipexists {
233 my $self = shift;
234 my $ip = shift;
235 my $sth = $dbh->prepare("SELECT count, exclude FROM iplist WHERE ip=?");
236 $sth->execute($ip);
237 my $ret = $sth->fetchrow_arrayref();
238 return $ret;
239} # end ipexists()
240
241
242# report an IP or URI to the db
243# increments a hit counter iff the reported IP or URI exists, otherwise it adds it
244sub report {
245 my $self = shift;
246 my $rep = shift;
247 my $exclude = shift || 'n';
248 $exclude = 'y' if $exclude eq 'on';
249 my $sth;
250 my $rows = 0;
251
252 local $dbh->{AutoCommit} = 0;
253 local $dbh->{RaiseError} = 1;
254
255 if ($rep =~ /^[\d.]+$/) {
256 # weesa gonna ASS-U-ME IP addresses are sanely formatted.
257 eval {
258 $sth = $dbh->prepare("SELECT count FROM iplist WHERE ip=?");
259 $sth->execute($rep) or die "eep? ".$dbh->errstr."\n";
260 $rows = $sth->rows;
261 if ($rows == 0) {
262 $sth = $dbh->prepare("INSERT INTO iplist (ip,parent,exclude) VALUES ".
263 "(?,(SELECT block FROM blocks WHERE block >> ? ORDER BY level DESC LIMIT 1),?)");
264 $sth->execute($rep, $rep, $exclude) or die "couldn't add entry for $rep: ".$dbh->errstr."\n";
265 } elsif ($rows == 1) {
266 $sth = $dbh->prepare("UPDATE iplist SET count=count+1,".
267 " exclude = ? WHERE ip = ?");
268 $sth->execute($exclude, $rep) or die "couldn't update listing for $rep: ".$dbh->errstr."\n";
269 } else {
270 die "db corrupt: found $rows matches on $rep\n";
271 }
272 $sth = $dbh->prepare("SELECT block FROM blocks WHERE block >> ?");
273 $sth->execute($rep);
274 my $updsth = $dbh->prepare("UPDATE blocks SET ipcount=(".
275 "SELECT count(*) FROM iplist i JOIN blocks b ON b.block=i.parent WHERE i.ip << ? AND i.exclude='n' AND b.exclude='n'".
276 ") WHERE block = ?");
277 while (my ($block) = $sth->fetchrow_array) {
278 $updsth->execute($block,$block);
279 }
280 $dbh->commit;
281 };
282 if ($@) {
283 my $msg = $@;
284 return "failed adding $rep: $msg";
285 }
286 } else {
287 return;
288 }
289 return $rows;
290} # end report()
291
292
293# add a new org
294# return the orgid
295# if the org exists, return the orgid anyway
296sub addorg {
297 my $self = shift;
298 my $orgname = shift;
299 my $listme = shift || 'n';
300 my $ret = $self->orgexists($orgname);
301 return $ret if $ret;
302 my $sth = $dbh->prepare("INSERT INTO orgs (orgname,listme) VALUES (?,?)");
303 $sth->execute($orgname,$listme) or die "couldn't add org $orgname: ".$dbh->errstr."\n";
304 $dbh->commit;
305 $sth = $dbh->prepare("SELECT orgid FROM orgs WHERE orgname=?");
306 $sth->execute($orgname);
307 my ($orgid) = $sth->fetchrow_array();
308 return $orgid;
309} # end addorg
310
311
312# checks for existence - nb, exact match! No way to really handle anything else. :/
313sub orgexists {
314 my $self = shift;
315 my $org = shift;
316 my $sth = $dbh->prepare("SELECT orgid FROM orgs WHERE orgname=?");
317 $sth->execute($org);
318 my ($ret) = $sth->fetchrow_array();
319 return $ret;
320} # end orgexists();
321
322
323# take an arbitrary IP range and an IP, and return the CIDR block (if any) the IP is in.
324sub range2cidr {
325 my $self = shift;
326 my $rstart = shift;
327 my $rend = shift;
328 my $ip = shift;
329
330 $rstart = new NetAddr::IP $rstart;
331 $rend = new NetAddr::IP $rend;
332 # Basic algoithm: Set the mask on the IP, and see if both $rstart and $rend
333 # are within the range defined by that IP/mask. Continue making the mask
334 # larger until success.
335
336 my $mask;
337 for ($mask = 32; $mask > 0; $mask--) {
338 my $ip = NetAddr::IP->new("$ip/$mask");
339 if (NetAddr::IP->new($ip->network->addr) >= $rstart &&
340 NetAddr::IP->new($ip->broadcast->addr) <= $rend) {
341 next;
342 } else {
343 $mask++;
344 last;
345 }
346 }
347 my $realnet = NetAddr::IP->new("$ip/$mask")->network;
348
349 return "$realnet";
350} # end range2cidr()
351
352
353# add a block. requires the orgid
354##fixme needs error handling
355sub addblock {
356 my $self = shift;
357 my $blockin = shift;
358 my $orgid = shift;
359 my $level = shift;
360 my $exclude = shift || 'n';
361 my $comment = shift;
362 $blockin =~ s/^\s+//;
363 $blockin =~ s/\s+$//;
364 my $block = new NetAddr::IP "$blockin"; # need this to clean up messes like ranges. sigh.
365
366 return "$blockin not a single CIDR range" if !$block;
367
368 local $dbh->{AutoCommit} = 0;
369 local $dbh->{RaiseError} = 1;
370
371 my $sth;
372 eval {
373 my $parent = '0/0';
374 if ($level > 0) {
375 $sth = $dbh->prepare("SELECT block FROM blocks WHERE block >> ? ORDER BY level DESC LIMIT 1");
376 $sth->execute("$block");
377 ($parent) = $sth->fetchrow_array;
378 }
379 $dbh->do("INSERT INTO blocks (block,orgid,level,parent,exclude,comments,ipcount) VALUES (?,?,?,?,?,?,".
380 "(SELECT count(*) FROM iplist i JOIN blocks b ON b.block=i.parent WHERE i.ip << ? AND i.exclude='n' AND b.exclude='n'))",
381 undef, "$block",$orgid,$level,$parent,$exclude,$comment,"$block");
382 $dbh->do("UPDATE iplist SET parent=? WHERE parent=? AND ip << ?", undef, "$block", $parent, "$block");
383 $dbh->commit;
384 };
385 if ($@) {
386 my $msg = $@;
387 eval { dbh->rollback; };
388 return "failed to add $block: $msg";
389 }
390 # nb: no need to return anything, since the CIDR block is the key
391}
392
393
394# Update a netblock entry. Supports (un)setting the exclude flag and the comment.
395# Does NOT do any magic around leftover IPs within the block
396sub updateblock {
397 my $self = shift;
398 my $blockin = shift;
399 my $orgid = shift;
400 my $level = shift;
401 my $exclude = shift || 'n';
402 my $comment = shift;
403 $blockin =~ s/^\s+//;
404 $blockin =~ s/\s+$//;
405 my $block = new NetAddr::IP "$blockin"; # need this to clean up messes like ranges. sigh.
406
407 return "$blockin not a single CIDR range" if !$block;
408
409 local $dbh->{AutoCommit} = 0;
410 local $dbh->{RaiseError} = 1;
411
412 my $sth;
413 eval {
414 my $parent = '0/0';
415 if ($level > 0) {
416 $sth = $dbh->prepare("SELECT block FROM blocks WHERE block >> ? ORDER BY level DESC LIMIT 1");
417 $sth->execute("$block");
418 ($parent) = $sth->fetchrow_array;
419 }
420 $sth = $dbh->prepare("UPDATE blocks SET exclude = ?, comments = ?, ipcount = ".
421 "(SELECT count(*) FROM iplist i JOIN blocks b ON b.block=i.parent WHERE i.ip << ? AND i.exclude='n' AND b.exclude='n')".
422 " WHERE block = ?");
423 $sth->execute($exclude, $comment, "$block", "$block");
424 $sth = $dbh->prepare("UPDATE iplist SET parent=? WHERE parent=? AND ip << ?");
425 $sth->execute("$block", $parent, "$block");
426 $dbh->commit;
427 };
428 if ($@) {
429 my $msg = $@;
430 eval { dbh->rollback; };
431 return "failed to update $block: $msg";
432 }
433 # nb: no need to return anything, since the CIDR block is the key
434} # updateblock()
435
436
437sub blockexists {
438 my $self = shift;
439 my $block = shift;
440 my $sth = $dbh->prepare("SELECT count(*) FROM blocks WHERE block=?");
441 $sth->execute($block);
442 my ($ret) = $sth->fetchrow_array();
443 return $ret;
444}
445
446
447# returns list (block,blockcomment,orgname) for the block that contains the passed IP.
448# accepts a level argument if you don't want the top-level registrar allocation block
449sub getcontainer {
450 my $self = shift;
451 my $ip = shift;
452 my $level = shift || 0;
453 my $sth = $dbh->prepare("SELECT b.block,b.comments,o.orgname FROM blocks b INNER JOIN orgs o ".
454 "ON b.orgid=o.orgid WHERE b.block >> ? AND b.level = ?");
455 $sth->execute($ip,$level);
456 return $sth->fetchrow_array();
457} # end getcontainer()
458
459
460# Get info about whether a block, IP or org is listed
461# Returns ?
462sub islisted {
463 my $self = shift;
464 my $entity = shift;
465
466 my $sth;
467
468 if ($entity =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
469 # looking for IP
470
471 $sth = $dbh->prepare("SELECT ip,s4list,exclude FROM iplist WHERE ip=?");
472 $sth->execute($entity);
473 my @ret = $sth->fetchrow_array;
474 return @ret if @ret;
475
476 } elsif ($entity =~ m|^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}/(\d+)$|) {
477 # block
478
479 my $masklen = $1;
480
481 $sth = $dbh->prepare("SELECT block,listme,exclude,ipcount FROM blocks WHERE block = ?");
482 $sth->execute($entity);
483 my ($block, $listme, $exclude, $bcount) = $sth->fetchrow_array;
484
485 return if !$block;
486
487 my @ret = ( ($bcount >= $autolist{$masklen}), $listme, $exclude);
488 return @ret;
489
490 } else {
491 # org
492
493 $sth = $dbh->prepare("SELECT orgid,listme FROM orgs WHERE orgname=?");
494 $sth->execute($entity);
495 my ($orgid,$listme) = $sth->fetchrow_array;
496 return $listme if $orgid;
497
498 }
499
500 return undef;
501
502} # end islisted()
503
504
505# whee! Recursion is Fun!
506# Call ourself to dig down through the layers of blocks from registar-allocation
507# (level 0) to final block (level n, not to exceed $maxlvl)
508# Take a reference to a hash, and stuff it full of blacklisting goodness.
509# Optionally accept a level, block-container, and OOB block and org arguments for
510# the container to check and return
511# Returns no value directly
512# Calls itself to walk down the tree of containers
513sub export {
514 my $self = shift;
515 my $listhosts = shift;
516
517# Export data as CIDR netblocks or classful (A/B/C) blocks
518# Assume classful as it's more compatible with different DNS servers
519 my $mode = shift || 'class';
520
521# Assume we're checking the whole enchilada if we don't get told where to look.
522 my $level = shift || 0;
523 my $container = shift || '0.0.0.0/0';
524 my $bitmask = shift || 0;
525
526 if ($level == 0) {
527 $errstr = '';
528 }
529
530 return if ($errstr =~ /no connection to the server/);
531 if ($level > $maxlvl) {
532 warn "getting too deep, breaking off! ($container, $level)\n";
533 return;
534 }
535
536# fiddle $container into a sane state.
537 if ($container =~ m|^\d+\.\d+\.\d+/\d+$|) {
538 $container =~ s|/(\d+)$|.0/$1|;
539 } elsif ($container =~ m|^\d+\.\d+/\d+$|) {
540 $container =~ s|/(\d+)$|.0.0/$1|;
541 } elsif ($container =~ m|^\d+/(\d+)$|) {
542 $container =~ s|/(\d+)$|.0.0.0/$1|;
543 }
544
545
546 # catch database-went-away errors
547 local $dbh->{RaiseError} = 1;
548 eval {
549
550
551 my $sth = $dbh->prepare("SELECT count(*) FROM blocks WHERE parent = ?");
552 $sth->execute($container);
553 my ($nblocks) = $sth->fetchrow_array();
554
555 # need this for a bunch of things, may as well do it here
556 my ($masklen) = ($container =~ m|/(\d+)$|);
557
558# Update the bitmask variable with the current block info as needed.
559# Much faster than retrieving this data later (~3x faster!).
560 my $listme;
561 my $listorg;
562 my $bcount;
563 my $bexclude;
564 if ($container ne '0.0.0.0/0') {
565 $sth = $dbh->prepare("SELECT b.ipcount,b.listme,b.exclude,o.listme ".
566 "FROM blocks b INNER JOIN orgs o ON b.orgid=o.orgid ".
567 "WHERE b.block = ?");
568 $sth->execute($container);
569 ($bcount,$listme,$bexclude,$listorg) = $sth->fetchrow_array();
570 $bcount = 0 if !$bcount;
571 $bitmask |= $bitfields{$level-1} if $bcount >= $autolist{$masklen};
572 $bitmask |= $bitfields{"block".($level-1)} if $listme;
573 $bitmask |= $bitfields{"org".($level-1)} if $listorg;
574 }
575
576# hm. can't seem to move this prepare elsewhere. :(
577 if ($nblocks > 0) {
578 my $sthsubblocks = $dbh->prepare("SELECT block,exclude FROM blocks ".
579 "WHERE level = ? AND parent = ?");
580 $sthsubblocks->execute($level, $container);
581 while (my ($cidr, $exclude) = $sthsubblocks->fetchrow_array()) {
582 if ($exclude) {
583 $listhosts->{$cidr} = -1;
584 } else { # don't check subtrees of an excluded block; rbldnsd doesn't support deep flip-flopping like that
585 $self->export($listhosts,$mode,$level+1,$cidr,$bitmask)
586 or die $errstr;
587 }
588 }
589 } # avoid checking content of subs if we don't have any
590
591 # don't check all 4.2 billion IPs individually if we're looking at all teh Intarwebs
592 return if $container eq '0.0.0.0/0';
593
594##fixme: need a way to dig out orphan IPs at all levels - IPs not found in a
595# subblock of the current container when the current container *has* subblocks
596# NB: this may be better handled as an out-of-band data-integrity-checker
597
598 # decrement level here so the right bitfield setting gets picked. this segment
599 # is inherently off-by-one from the block-recursion loop, and I can't see a
600 # better way to work around that. >:(
601 $level--;
602
603 if ($mode eq 'cidr') {
604 $listhosts->{$container} |= $bitmask if $bitmask && ($listme || $listorg || ($bcount >= $autolist{$masklen}));
605 } else {
606 # if $cidr->masklen is <= 24, iterate on /24 boundaries for bulk sublisting
607 # if $cidr->masklen is <= 16, iterate on /16 boundaries for bulk sublisting
608 # if $cidr->masklen is <= 8, iterate on /8 boundaries for bulk sublisting
609
610 if ($bitmask) {
611 my @blocksubs;
612 if ($masklen <= 30 && $masklen > 24) {
613 my ($net,$octet) = ($container =~ m|^(\d+\.\d+\.\d+\.)(\d+)/|);
614 for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
615 my $host = "$net$entry";
616 $listhosts->{$host} = 0 if !defined($listhosts->{$host});
617 $listhosts->{$host} |= $bitmask;
618 }
619 } elsif ($masklen <= 24 && $masklen > 16) {
620 my ($net,$octet) = ($container =~ m|^(\d+\.\d+\.)(\d+)\.\d+/|);
621 for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
622 my $twofour = "$net$entry.*";
623 $listhosts->{$twofour} |= $bitmask;
624 }
625 } elsif ($masklen <= 16 && $masklen > 8) {
626 my ($net,$octet) = ($container =~ m|^(\d+\.)(\d+)\.\d+\.\d+/|);
627 for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
628 my $sixteen = "$net$entry.*";
629 $listhosts->{$sixteen} |= $bitmask;
630 }
631 } elsif ($masklen <= 8) {
632 my ($octet) = ($container =~ m|^(\d+)\.\d+\.\d+\.\d+/|);
633 for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
634 my $eight = "$entry.*";
635 $listhosts->{$eight} |= $bitmask;
636 }
637 }
638
639 } # generate autolist entries for ips/octets not (yet) seen in reports
640
641 } # cidr vs classful mode
642
643 $sthmoron->execute($container);
644 while (my ($ip,$moron,$exclude) = $sthmoron->fetchrow_array()) {
645 if ($moron) {
646 $listhosts->{$ip} = $bitfields{slist};
647 } elsif ($exclude) {
648 $listhosts->{$ip} = -1;
649 } else {
650 $listhosts->{$ip} |= $bitmask;
651 $listhosts->{$ip} |= $bitfields{ip};
652 }
653 }
654
655
656 }; # db-went-away-catching eval
657 if ($@) {
658 $errstr = $@;
659 warn "export truncated: $errstr\n";
660 return;
661 }
662
663
664# get IPs which for reasons unknown are apparently allocated directly from the
665# parent registry (and so do not have containing netblocks in this system) O_o
666# select * from iplist where not (select count(*) from blocks where ip << block) > 0;
667
668 return 1;
669} # end export()
670
671
672## DNSBL::autolist_block()
673# check if a block should be autolisted
674sub autolist_block {
675 my $self = shift;
676 my $block = shift;
677
678 my $cidr = new NetAddr::IP "$block";
679 my $sth = $dbh->prepare("SELECT ipcount FROM blocks WHERE block = ?");
680 $sth->execute("$cidr");
681 my ($count) = $sth->fetchrow_array;
682
683 return 1 if $count >= $autolist{$cidr->masklen};
684 return 0;
685} # end autolist_block()
686
687
688# make Perl happy
6891;
Note: See TracBrowser for help on using the repository browser.