source: trunk/dnsbl/DNSBL.pm@ 92

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

/trunk/dnsbl

Convert per-script %config to module-based loader stub in DNSBL::new()
  • 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 92 2025-09-16 19:56:31Z 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->rollback;
191 $dbh->disconnect;
192}
193
194## specific object subs:
195
196sub connect {
197 my $self = shift;
198 ## want to NOT autocommit everything, it's unlikely we'll step on our own toes but...
199 $dbh = DBI->connect("DBI:Pg:host=$self->{dbhost};dbname=$self->{dbname}", $self->{dbuser}, $self->{dbpass}, {
200 AutoCommit => 0,
201 PrintError => 1
202 })
203 or die "database inaccessible: ".$DBI::errstr;
204 my $sth = $dbh->prepare("SELECT masklen,ipcount FROM autolist");
205 $sth->execute;
206 while (my ($masklen,$ipcount) = $sth->fetchrow_array) {
207 $autolist{$masklen} = $ipcount;
208 }
209 my $sth = $dbh->prepare("SELECT key,value FROM misc");
210 $sth->execute;
211 while (my ($key,$value) = $sth->fetchrow_array) {
212 $self->{misc}{$key} = $value;
213 }
214 return $dbh;
215}
216
217
218## DNSBLDB::initexport()
219# Prepare a couple of statement handles for later processing in export(). Assists in ~3x speed increase.
220my $parsth;
221my $sthmoron;
222sub initexport {
223 $parsth = $dbh->prepare("SELECT count(i.ip),b.block,b.level,b.listme AS oobblock,o.listme AS ooborg ".
224 "FROM iplist i INNER JOIN blocks b ON i.parent = b.block INNER JOIN orgs o ON b.orgid = o.orgid ".
225 "WHERE b.block >>= ? ".
226 "GROUP BY b.block,b.level,b.listme,o.listme ORDER BY b.block");
227 $sthmoron = $dbh->prepare("SELECT ip,s4list,exclude FROM iplist WHERE parent = ?");
228}
229
230
231## DNSBL::ipexists()
232# return report count if the IP has been reported, otherwise return undef
233sub ipexists {
234 my $self = shift;
235 my $ip = shift;
236 my $sth = $dbh->prepare("SELECT count, exclude FROM iplist WHERE ip=?");
237 $sth->execute($ip);
238 my $ret = $sth->fetchrow_arrayref();
239 return $ret;
240} # end ipexists()
241
242
243# report an IP or URI to the db
244# increments a hit counter iff the reported IP or URI exists, otherwise it adds it
245sub report {
246 my $self = shift;
247 my $rep = shift;
248 my $exclude = shift || 'n';
249 $exclude = 'y' if $exclude eq 'on';
250 my $sth;
251 my $rows = 0;
252 if ($rep =~ /^[\d.]+$/) {
253 # weesa gonna ASS-U-ME IP addresses are sanely formatted.
254 eval {
255 $sth = $dbh->prepare("SELECT count FROM iplist WHERE ip=?");
256 $sth->execute($rep) or die "eep? ".$dbh->errstr."\n";
257 $rows = $sth->rows;
258 if ($rows == 0) {
259 $sth = $dbh->prepare("INSERT INTO iplist (ip,parent,exclude) VALUES ".
260 "(?,(SELECT block FROM blocks WHERE block >> ? ORDER BY level DESC LIMIT 1),?)");
261 $sth->execute($rep, $rep, $exclude) or die "couldn't add entry for $rep: ".$dbh->errstr."\n";
262 } elsif ($rows == 1) {
263 $sth = $dbh->prepare("UPDATE iplist SET count=count+1,".
264 " exclude = ? WHERE ip = ?");
265 $sth->execute($exclude, $rep) or die "couldn't update listing for $rep: ".$dbh->errstr."\n";
266 } else {
267 die "db corrupt: found $rows matches on $rep\n";
268 }
269 $sth = $dbh->prepare("SELECT block FROM blocks WHERE block >> ?");
270 $sth->execute($rep);
271 my $updsth = $dbh->prepare("UPDATE blocks SET ipcount=(".
272 "SELECT count(*) FROM iplist i JOIN blocks b ON b.block=i.parent WHERE i.ip << ? AND i.exclude='n' AND b.exclude='n'".
273 ") WHERE block = ?");
274 while (my ($block) = $sth->fetchrow_array) {
275 $updsth->execute($block,$block);
276 }
277 $dbh->commit;
278 };
279 if ($@) {
280 my $msg = $@;
281 return "failed adding $rep: $msg";
282 }
283 } else {
284 return;
285 }
286 return $rows;
287} # end report()
288
289
290# add a new org
291# return the orgid
292# if the org exists, return the orgid anyway
293sub addorg {
294 my $self = shift;
295 my $orgname = shift;
296 my $listme = shift || 'n';
297 my $ret = $self->orgexists($orgname);
298 return $ret if $ret;
299 my $sth = $dbh->prepare("INSERT INTO orgs (orgname,listme) VALUES (?,?)");
300 $sth->execute($orgname,$listme) or die "couldn't add org $orgname: ".$dbh->errstr."\n";
301 $dbh->commit;
302 $sth = $dbh->prepare("SELECT orgid FROM orgs WHERE orgname=?");
303 $sth->execute($orgname);
304 my ($orgid) = $sth->fetchrow_array();
305 return $orgid;
306} # end addorg
307
308
309# checks for existence - nb, exact match! No way to really handle anything else. :/
310sub orgexists {
311 my $self = shift;
312 my $org = shift;
313 my $sth = $dbh->prepare("SELECT orgid FROM orgs WHERE orgname=?");
314 $sth->execute($org);
315 my ($ret) = $sth->fetchrow_array();
316 return $ret;
317} # end orgexists();
318
319
320# take an arbitrary IP range and an IP, and return the CIDR block (if any) the IP is in.
321sub range2cidr {
322 my $self = shift;
323 my $rstart = shift;
324 my $rend = shift;
325 my $ip = shift;
326
327 $rstart = new NetAddr::IP $rstart;
328 $rend = new NetAddr::IP $rend;
329 # Basic algoithm: Set the mask on the IP, and see if both $rstart and $rend
330 # are within the range defined by that IP/mask. Continue making the mask
331 # larger until success.
332
333 my $mask;
334 for ($mask = 32; $mask > 0; $mask--) {
335 my $ip = NetAddr::IP->new("$ip/$mask");
336 if (NetAddr::IP->new($ip->network->addr) >= $rstart &&
337 NetAddr::IP->new($ip->broadcast->addr) <= $rend) {
338 next;
339 } else {
340 $mask++;
341 last;
342 }
343 }
344 my $realnet = NetAddr::IP->new("$ip/$mask")->network;
345
346 return "$realnet";
347} # end range2cidr()
348
349
350# add a block. requires the orgid
351##fixme needs error handling
352sub addblock {
353 my $self = shift;
354 my $blockin = shift;
355 my $orgid = shift;
356 my $level = shift;
357 my $exclude = shift || 'n';
358 my $comment = shift;
359 $blockin =~ s/^\s+//;
360 $blockin =~ s/\s+$//;
361 my $block = new NetAddr::IP "$blockin"; # need this to clean up messes like ranges. sigh.
362
363 return "$blockin not a single CIDR range" if !$block;
364
365# local $dbh->{AutoCommit} = 1; # force autocommit
366
367 my $sth;
368 eval {
369 my $parent = '0/0';
370 if ($level > 0) {
371 $sth = $dbh->prepare("SELECT block FROM blocks WHERE block >> ? ORDER BY level DESC LIMIT 1");
372 $sth->execute("$block");
373 ($parent) = $sth->fetchrow_array;
374 }
375 $sth = $dbh->prepare("INSERT INTO blocks (block,orgid,level,parent,exclude,comments,ipcount) VALUES (?,?,?,?,?,?,".
376 "(SELECT count(*) FROM iplist i JOIN blocks b ON b.block=i.parent WHERE i.ip << ? AND i.exclude='n' AND b.exclude='n'))");
377 $sth->execute("$block",$orgid,$level,$parent,$exclude,$comment,"$block");
378 $sth = $dbh->prepare("UPDATE iplist SET parent=? WHERE parent=? AND ip << ?");
379 $sth->execute("$block",$parent,"$block");
380 $dbh->commit;
381 };
382 if ($@) {
383 my $msg = $@;
384 eval { dbh->rollback; };
385 return "failed to add $block: $msg";
386 }
387 # nb: no need to return anything, since the CIDR block is the key
388}
389
390
391# Update a netblock entry. Supports (un)setting the exclude flag and the comment.
392# Does NOT do any magic around leftover IPs within the block
393sub updateblock {
394 my $self = shift;
395 my $blockin = shift;
396 my $orgid = shift;
397 my $level = shift;
398 my $exclude = shift || 'n';
399 my $comment = shift;
400 $blockin =~ s/^\s+//;
401 $blockin =~ s/\s+$//;
402 my $block = new NetAddr::IP "$blockin"; # need this to clean up messes like ranges. sigh.
403
404 return "$blockin not a single CIDR range" if !$block;
405
406 local $dbh->{AutoCommit} = 0;
407 local $dbh->{RaiseError} = 1;
408
409 my $sth;
410 eval {
411 my $parent = '0/0';
412 if ($level > 0) {
413 $sth = $dbh->prepare("SELECT block FROM blocks WHERE block >> ? ORDER BY level DESC LIMIT 1");
414 $sth->execute("$block");
415 ($parent) = $sth->fetchrow_array;
416 }
417 $sth = $dbh->prepare("UPDATE blocks SET exclude = ?, comments = ?, ipcount = ".
418 "(SELECT count(*) FROM iplist i JOIN blocks b ON b.block=i.parent WHERE i.ip << ? AND i.exclude='n' AND b.exclude='n')".
419 " WHERE block = ?");
420 $sth->execute($exclude, $comment, "$block", "$block");
421 $sth = $dbh->prepare("UPDATE iplist SET parent=? WHERE parent=? AND ip << ?");
422 $sth->execute("$block", $parent, "$block");
423 $dbh->commit;
424 };
425 if ($@) {
426 my $msg = $@;
427 eval { dbh->rollback; };
428 return "failed to update $block: $msg";
429 }
430 # nb: no need to return anything, since the CIDR block is the key
431} # updateblock()
432
433
434sub blockexists {
435 my $self = shift;
436 my $block = shift;
437 my $sth = $dbh->prepare("SELECT count(*) FROM blocks WHERE block=?");
438 $sth->execute($block);
439 my ($ret) = $sth->fetchrow_array();
440 return $ret;
441}
442
443
444# returns list (block,blockcomment,orgname) for the block that contains the passed IP.
445# accepts a level argument if you don't want the top-level registrar allocation block
446sub getcontainer {
447 my $self = shift;
448 my $ip = shift;
449 my $level = shift || 0;
450 my $sth = $dbh->prepare("SELECT b.block,b.comments,o.orgname FROM blocks b INNER JOIN orgs o ".
451 "ON b.orgid=o.orgid WHERE b.block >> ? AND b.level = ?");
452 $sth->execute($ip,$level);
453 return $sth->fetchrow_array();
454} # end getcontainer()
455
456
457# Get info about whether a block, IP or org is listed
458# Returns ?
459sub islisted {
460 my $self = shift;
461 my $entity = shift;
462
463 my $sth;
464
465 if ($entity =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
466 # looking for IP
467
468 $sth = $dbh->prepare("SELECT ip,s4list,exclude FROM iplist WHERE ip=?");
469 $sth->execute($entity);
470 my @ret = $sth->fetchrow_array;
471 return @ret if @ret;
472
473 } elsif ($entity =~ m|^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}/(\d+)$|) {
474 # block
475
476 my $masklen = $1;
477
478 $sth = $dbh->prepare("SELECT block,listme,exclude,ipcount FROM blocks WHERE block = ?");
479 $sth->execute($entity);
480 my ($block, $listme, $exclude, $bcount) = $sth->fetchrow_array;
481
482 return if !$block;
483
484 my @ret = ( ($bcount >= $autolist{$masklen}), $listme, $exclude);
485 return @ret;
486
487 } else {
488 # org
489
490 $sth = $dbh->prepare("SELECT orgid,listme FROM orgs WHERE orgname=?");
491 $sth->execute($entity);
492 my ($orgid,$listme) = $sth->fetchrow_array;
493 return $listme if $orgid;
494
495 }
496
497 return undef;
498
499} # end islisted()
500
501
502# whee! Recursion is Fun!
503# Call ourself to dig down through the layers of blocks from registar-allocation
504# (level 0) to final block (level n, not to exceed $maxlvl)
505# Take a reference to a hash, and stuff it full of blacklisting goodness.
506# Optionally accept a level, block-container, and OOB block and org arguments for
507# the container to check and return
508# Returns no value directly
509# Calls itself to walk down the tree of containers
510sub export {
511 my $self = shift;
512 my $listhosts = shift;
513
514# Export data as CIDR netblocks or classful (A/B/C) blocks
515# Assume classful as it's more compatible with different DNS servers
516 my $mode = shift || 'class';
517
518# Assume we're checking the whole enchilada if we don't get told where to look.
519 my $level = shift || 0;
520 my $container = shift || '0.0.0.0/0';
521 my $bitmask = shift || 0;
522
523 if ($level == 0) {
524 $errstr = '';
525 }
526
527 return if ($errstr =~ /no connection to the server/);
528 if ($level > $maxlvl) {
529 warn "getting too deep, breaking off! ($container, $level)\n";
530 return;
531 }
532
533# fiddle $container into a sane state.
534 if ($container =~ m|^\d+\.\d+\.\d+/\d+$|) {
535 $container =~ s|/(\d+)$|.0/$1|;
536 } elsif ($container =~ m|^\d+\.\d+/\d+$|) {
537 $container =~ s|/(\d+)$|.0.0/$1|;
538 } elsif ($container =~ m|^\d+/(\d+)$|) {
539 $container =~ s|/(\d+)$|.0.0.0/$1|;
540 }
541
542
543 # catch database-went-away errors
544 local $dbh->{RaiseError} = 1;
545 eval {
546
547
548 my $sth = $dbh->prepare("SELECT count(*) FROM blocks WHERE parent = ?");
549 $sth->execute($container);
550 my ($nblocks) = $sth->fetchrow_array();
551
552 # need this for a bunch of things, may as well do it here
553 my ($masklen) = ($container =~ m|/(\d+)$|);
554
555# Update the bitmask variable with the current block info as needed.
556# Much faster than retrieving this data later (~3x faster!).
557 my $listme;
558 my $listorg;
559 my $bcount;
560 my $bexclude;
561 if ($container ne '0.0.0.0/0') {
562 $sth = $dbh->prepare("SELECT b.ipcount,b.listme,b.exclude,o.listme ".
563 "FROM blocks b INNER JOIN orgs o ON b.orgid=o.orgid ".
564 "WHERE b.block = ?");
565 $sth->execute($container);
566 ($bcount,$listme,$bexclude,$listorg) = $sth->fetchrow_array();
567 $bcount = 0 if !$bcount;
568 $bitmask |= $bitfields{$level-1} if $bcount >= $autolist{$masklen};
569 $bitmask |= $bitfields{"block".($level-1)} if $listme;
570 $bitmask |= $bitfields{"org".($level-1)} if $listorg;
571 }
572
573# hm. can't seem to move this prepare elsewhere. :(
574 if ($nblocks > 0) {
575 my $sthsubblocks = $dbh->prepare("SELECT block,exclude FROM blocks ".
576 "WHERE level = ? AND parent = ?");
577 $sthsubblocks->execute($level, $container);
578 while (my ($cidr, $exclude) = $sthsubblocks->fetchrow_array()) {
579 if ($exclude) {
580 $listhosts->{$cidr} = -1;
581 } else { # don't check subtrees of an excluded block; rbldnsd doesn't support deep flip-flopping like that
582 $self->export($listhosts,$mode,$level+1,$cidr,$bitmask)
583 or die $errstr;
584 }
585 }
586 } # avoid checking content of subs if we don't have any
587
588 # don't check all 4.2 billion IPs individually if we're looking at all teh Intarwebs
589 return if $container eq '0.0.0.0/0';
590
591##fixme: need a way to dig out orphan IPs at all levels - IPs not found in a
592# subblock of the current container when the current container *has* subblocks
593# NB: this may be better handled as an out-of-band data-integrity-checker
594
595 # decrement level here so the right bitfield setting gets picked. this segment
596 # is inherently off-by-one from the block-recursion loop, and I can't see a
597 # better way to work around that. >:(
598 $level--;
599
600 if ($mode eq 'cidr') {
601 $listhosts->{$container} |= $bitmask if $bitmask && ($listme || $listorg || ($bcount >= $autolist{$masklen}));
602 } else {
603 # if $cidr->masklen is <= 24, iterate on /24 boundaries for bulk sublisting
604 # if $cidr->masklen is <= 16, iterate on /16 boundaries for bulk sublisting
605 # if $cidr->masklen is <= 8, iterate on /8 boundaries for bulk sublisting
606
607 if ($bitmask) {
608 my @blocksubs;
609 if ($masklen <= 30 && $masklen > 24) {
610 my ($net,$octet) = ($container =~ m|^(\d+\.\d+\.\d+\.)(\d+)/|);
611 for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
612 my $host = "$net$entry";
613 $listhosts->{$host} = 0 if !defined($listhosts->{$host});
614 $listhosts->{$host} |= $bitmask;
615 }
616 } elsif ($masklen <= 24 && $masklen > 16) {
617 my ($net,$octet) = ($container =~ m|^(\d+\.\d+\.)(\d+)\.\d+/|);
618 for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
619 my $twofour = "$net$entry.*";
620 $listhosts->{$twofour} |= $bitmask;
621 }
622 } elsif ($masklen <= 16 && $masklen > 8) {
623 my ($net,$octet) = ($container =~ m|^(\d+\.)(\d+)\.\d+\.\d+/|);
624 for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
625 my $sixteen = "$net$entry.*";
626 $listhosts->{$sixteen} |= $bitmask;
627 }
628 } elsif ($masklen <= 8) {
629 my ($octet) = ($container =~ m|^(\d+)\.\d+\.\d+\.\d+/|);
630 for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
631 my $eight = "$entry.*";
632 $listhosts->{$eight} |= $bitmask;
633 }
634 }
635
636 } # generate autolist entries for ips/octets not (yet) seen in reports
637
638 } # cidr vs classful mode
639
640 $sthmoron->execute($container);
641 while (my ($ip,$moron,$exclude) = $sthmoron->fetchrow_array()) {
642 if ($moron) {
643 $listhosts->{$ip} = $bitfields{slist};
644 } elsif ($exclude) {
645 $listhosts->{$ip} = -1;
646 } else {
647 $listhosts->{$ip} |= $bitmask;
648 $listhosts->{$ip} |= $bitfields{ip};
649 }
650 }
651
652
653 }; # db-went-away-catching eval
654 if ($@) {
655 $errstr = $@;
656 warn "export truncated: $errstr\n";
657 return;
658 }
659
660
661# get IPs which for reasons unknown are apparently allocated directly from the
662# parent registry (and so do not have containing netblocks in this system) O_o
663# select * from iplist where not (select count(*) from blocks where ip << block) > 0;
664
665 return 1;
666} # end export()
667
668
669## DNSBL::autolist_block()
670# check if a block should be autolisted
671sub autolist_block {
672 my $self = shift;
673 my $block = shift;
674
675 my $cidr = new NetAddr::IP "$block";
676 my $sth = $dbh->prepare("SELECT ipcount FROM blocks WHERE block = ?");
677 $sth->execute("$cidr");
678 my ($count) = $sth->fetchrow_array;
679
680 return 1 if $count >= $autolist{$cidr->masklen};
681 return 0;
682} # end autolist_block()
683
684
685# make Perl happy
6861;
Note: See TracBrowser for help on using the repository browser.