source: trunk/dnsbl/DNSBL.pm@ 75

Last change on this file since 75 was 75, checked in by Kris Deugau, 7 days ago

/trunk/dnsbl

Remove DNSBL::export_alt() which I've long since forgotten the intention

for, and which was never more than an opening stub

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