| 1 | # DNSBL
|
|---|
| 2 | # Functions for interacting with the DNSBL database
|
|---|
| 3 |
|
|---|
| 4 | package DNSBL;
|
|---|
| 5 |
|
|---|
| 6 | use strict;
|
|---|
| 7 | use warnings;
|
|---|
| 8 | use Exporter;
|
|---|
| 9 | use DBI;
|
|---|
| 10 | use NetAddr::IP;
|
|---|
| 11 |
|
|---|
| 12 | use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
|
|---|
| 13 |
|
|---|
| 14 | $VERSION = 2.0;
|
|---|
| 15 | @ISA = qw(Exporter);
|
|---|
| 16 | @EXPORT_OK = qw(
|
|---|
| 17 | );
|
|---|
| 18 |
|
|---|
| 19 | @EXPORT = (); # Export nothing by default.
|
|---|
| 20 | %EXPORT_TAGS = ( ALL => [qw(
|
|---|
| 21 | )]
|
|---|
| 22 | );
|
|---|
| 23 |
|
|---|
| 24 | ## "constants"
|
|---|
| 25 |
|
|---|
| 26 | # 8 bits available
|
|---|
| 27 | # 128 is per-IP shitlist
|
|---|
| 28 | # 2 is IP hitlist
|
|---|
| 29 | # 1 not available so we don't $self->shoot(foot)
|
|---|
| 30 | our %bitfields = (
|
|---|
| 31 | # block levels
|
|---|
| 32 | 0 => 16,
|
|---|
| 33 | 1 => 8,
|
|---|
| 34 | 2 => 4,
|
|---|
| 35 | # ip
|
|---|
| 36 | ip => 2,
|
|---|
| 37 | # OOB
|
|---|
| 38 | org => 32,
|
|---|
| 39 | block => 64,
|
|---|
| 40 | # "I'm a total spamming moron!" - per-IP only!
|
|---|
| 41 | slist => 128
|
|---|
| 42 | );
|
|---|
| 43 |
|
|---|
| 44 | # probably needs some tuning; even 7 hits in a /24 is a pretty small percentage
|
|---|
| 45 | # number of IPs in a block of the given masklength needed to have that block automatically listed
|
|---|
| 46 | our %autolist = (
|
|---|
| 47 | 30 => 1,
|
|---|
| 48 | 29 => 2,
|
|---|
| 49 | 28 => 3,
|
|---|
| 50 | 27 => 4,
|
|---|
| 51 | 26 => 5,
|
|---|
| 52 | 25 => 6,
|
|---|
| 53 | 24 => 7,
|
|---|
| 54 | 23 => 8,
|
|---|
| 55 | 22 => 10,
|
|---|
| 56 | 21 => 12,
|
|---|
| 57 | 20 => 14,
|
|---|
| 58 | 19 => 16,
|
|---|
| 59 | 18 => 18,
|
|---|
| 60 | 17 => 20,
|
|---|
| 61 | 16 => 22,
|
|---|
| 62 | 15 => 24,
|
|---|
| 63 | 14 => 26,
|
|---|
| 64 | 13 => 28,
|
|---|
| 65 | 12 => 30,
|
|---|
| 66 | 11 => 32,
|
|---|
| 67 | 10 => 34,
|
|---|
| 68 | 9 => 36,
|
|---|
| 69 | 8 => 38,
|
|---|
| 70 | 7 => 2**31,
|
|---|
| 71 | 6 => 2**31,
|
|---|
| 72 | 5 => 2**31,
|
|---|
| 73 | 4 => 2**31,
|
|---|
| 74 | 3 => 2**31,
|
|---|
| 75 | 2 => 2**31,
|
|---|
| 76 | 1 => 2**31,
|
|---|
| 77 | 0 => 2**31
|
|---|
| 78 | );
|
|---|
| 79 |
|
|---|
| 80 | # le sigh. constants for masklength iterationing
|
|---|
| 81 | our @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);
|
|---|
| 82 |
|
|---|
| 83 | # variables
|
|---|
| 84 | our $dbh;
|
|---|
| 85 |
|
|---|
| 86 | our $err;
|
|---|
| 87 | our $errstr;
|
|---|
| 88 |
|
|---|
| 89 | # basic object subs
|
|---|
| 90 | sub new {
|
|---|
| 91 | # iff we want to start taking arguments, or doing other things on instantiation
|
|---|
| 92 | # my $self = {};
|
|---|
| 93 | # bless $self, "DNSBL";
|
|---|
| 94 | # return $self;
|
|---|
| 95 | bless {};
|
|---|
| 96 | }
|
|---|
| 97 |
|
|---|
| 98 | sub DESTROY {
|
|---|
| 99 | my $self = shift;
|
|---|
| 100 | $self->dbclose();
|
|---|
| 101 | }
|
|---|
| 102 |
|
|---|
| 103 | # JIC someone wants to close the db but not finish the script
|
|---|
| 104 | sub dbclose {
|
|---|
| 105 | $dbh->rollback;
|
|---|
| 106 | $dbh->disconnect;
|
|---|
| 107 | }
|
|---|
| 108 |
|
|---|
| 109 | ## specific object subs:
|
|---|
| 110 |
|
|---|
| 111 | sub connect {
|
|---|
| 112 | my $DSN = "DBI:Pg:host=dbhost;dbname=dnsbl";
|
|---|
| 113 | # my $DSN = "DBI:Pg:dbname=dnsbl";
|
|---|
| 114 | my $user = "dnsbl";
|
|---|
| 115 | my $pass = "spambgone";
|
|---|
| 116 | ## want to NOT autocommit everything, it's unlikely we'll step on our own toes but...
|
|---|
| 117 | $dbh = DBI->connect($DSN, $user, $pass, {
|
|---|
| 118 | AutoCommit => 0,
|
|---|
| 119 | PrintError => 1
|
|---|
| 120 | })
|
|---|
| 121 | or die "database inaccessible: ".$DBI::errstr;
|
|---|
| 122 | return $dbh;
|
|---|
| 123 | }
|
|---|
| 124 |
|
|---|
| 125 |
|
|---|
| 126 | ## DNSBL::ipexists()
|
|---|
| 127 | # return report count if the IP has been reported, otherwise return undef
|
|---|
| 128 | sub ipexists {
|
|---|
| 129 | my $self = shift;
|
|---|
| 130 | my $ip = shift;
|
|---|
| 131 | my $sth = $dbh->prepare("SELECT count FROM iplist WHERE ip=?");
|
|---|
| 132 | $sth->execute($ip);
|
|---|
| 133 | my ($ret) = $sth->fetchrow_array();
|
|---|
| 134 | return $ret;
|
|---|
| 135 | } # end ipexists()
|
|---|
| 136 |
|
|---|
| 137 |
|
|---|
| 138 | # report an IP or URI to the db
|
|---|
| 139 | # increments a hit counter iff the reported IP or URI exists, otherwise it adds it
|
|---|
| 140 | sub report {
|
|---|
| 141 | my $self = shift;
|
|---|
| 142 | my $rep = shift;
|
|---|
| 143 | my $sth;
|
|---|
| 144 | my $rows = 0;
|
|---|
| 145 | if ($rep =~ /^[\d.]+$/) {
|
|---|
| 146 | # weesa gonna ASS-U-ME IP addresses are sanely formatted.
|
|---|
| 147 | $sth = $dbh->prepare("SELECT count FROM iplist WHERE ip=?");
|
|---|
| 148 | $sth->execute($rep) or die "eep? ".$dbh->errstr."\n";
|
|---|
| 149 | $rows = $sth->rows;
|
|---|
| 150 | if ($rows == 0) {
|
|---|
| 151 | $sth = $dbh->prepare("INSERT INTO iplist (ip) VALUES (?)");
|
|---|
| 152 | } elsif ($rows == 1) {
|
|---|
| 153 | $sth = $dbh->prepare("UPDATE iplist SET count=count+1 WHERE ip=?");
|
|---|
| 154 | } else {
|
|---|
| 155 | die "db corrupt: found $rows matches on $rep\n";
|
|---|
| 156 | }
|
|---|
| 157 | $sth->execute($rep) or die "couldn't update listing for $rep: ".$dbh->errstr."\n";
|
|---|
| 158 | } else {
|
|---|
| 159 | return;
|
|---|
| 160 | }
|
|---|
| 161 | $dbh->commit;
|
|---|
| 162 | return $rows;
|
|---|
| 163 | } # end report()
|
|---|
| 164 |
|
|---|
| 165 |
|
|---|
| 166 | # add a new org
|
|---|
| 167 | # return the orgid
|
|---|
| 168 | # if the org exists, return the orgid anyway
|
|---|
| 169 | sub addorg {
|
|---|
| 170 | my $self = shift;
|
|---|
| 171 | my $orgname = shift;
|
|---|
| 172 | my $listme = shift || 'n';
|
|---|
| 173 | my $ret = $self->orgexists($orgname);
|
|---|
| 174 | return $ret if $ret;
|
|---|
| 175 | my $sth = $dbh->prepare("INSERT INTO orgs (orgname,listme) VALUES (?,?)");
|
|---|
| 176 | $sth->execute($orgname,$listme) or die "couldn't add org $orgname: ".$dbh->errstr."\n";
|
|---|
| 177 | $dbh->commit;
|
|---|
| 178 | $sth = $dbh->prepare("SELECT orgid FROM orgs WHERE orgname=?");
|
|---|
| 179 | $sth->execute($orgname);
|
|---|
| 180 | my ($orgid) = $sth->fetchrow_array();
|
|---|
| 181 | return $orgid;
|
|---|
| 182 | } # end addorg
|
|---|
| 183 |
|
|---|
| 184 |
|
|---|
| 185 | # checks for existence - nb, exact match! No way to really handle anything else. :/
|
|---|
| 186 | sub orgexists {
|
|---|
| 187 | my $self = shift;
|
|---|
| 188 | my $org = shift;
|
|---|
| 189 | my $sth = $dbh->prepare("SELECT orgid FROM orgs WHERE orgname=?");
|
|---|
| 190 | $sth->execute($org);
|
|---|
| 191 | my ($ret) = $sth->fetchrow_array();
|
|---|
| 192 | return $ret;
|
|---|
| 193 | } # end orgexists();
|
|---|
| 194 |
|
|---|
| 195 |
|
|---|
| 196 | # add a block. requires the orgid
|
|---|
| 197 | ##fixme needs error handling
|
|---|
| 198 | sub addblock {
|
|---|
| 199 | my $self = shift;
|
|---|
| 200 | my $blockin = shift;
|
|---|
| 201 | my $orgid = shift;
|
|---|
| 202 | my $level = shift;
|
|---|
| 203 | $blockin =~ s/^\s+//;
|
|---|
| 204 | $blockin =~ s/\s+$//;
|
|---|
| 205 | my $block = new NetAddr::IP "$blockin"; # need this to clean up messes like ranges. sigh.
|
|---|
| 206 |
|
|---|
| 207 | local $dbh->{AutoCommit} = 1; # force autocommit
|
|---|
| 208 |
|
|---|
| 209 | my $sth = $dbh->prepare("INSERT INTO blocks (block,orgid,level) VALUES (?,?,?)");
|
|---|
| 210 | $sth->execute("$block",$orgid,$level);
|
|---|
| 211 | # nb: no need to return anything, since the CIDR block is the key
|
|---|
| 212 | }
|
|---|
| 213 |
|
|---|
| 214 |
|
|---|
| 215 | sub blockexists {
|
|---|
| 216 | my $self = shift;
|
|---|
| 217 | my $block = shift;
|
|---|
| 218 | my $sth = $dbh->prepare("SELECT count(*) FROM blocks WHERE block=?");
|
|---|
| 219 | $sth->execute($block);
|
|---|
| 220 | my ($ret) = $sth->fetchrow_array();
|
|---|
| 221 | return $ret;
|
|---|
| 222 | }
|
|---|
| 223 |
|
|---|
| 224 |
|
|---|
| 225 | # returns list (block,orgname) for the block that contains the passed IP.
|
|---|
| 226 | # accepts a level argument if you don't want the top-level registrar allocation block
|
|---|
| 227 | sub getcontainer {
|
|---|
| 228 | my $self = shift;
|
|---|
| 229 | my $ip = shift;
|
|---|
| 230 | my $level = shift || 0;
|
|---|
| 231 | my $sth = $dbh->prepare("SELECT b.block,o.orgname FROM blocks b INNER JOIN orgs o ".
|
|---|
| 232 | "ON b.orgid=o.orgid WHERE b.block >> ? AND b.level = ?");
|
|---|
| 233 | $sth->execute($ip,$level);
|
|---|
| 234 | return $sth->fetchrow_array();
|
|---|
| 235 | } # end getcontainer()
|
|---|
| 236 |
|
|---|
| 237 |
|
|---|
| 238 | # whee! Recursion is Fun!
|
|---|
| 239 | # Call ourself to dig down through the layers of blocks from registar-allocation
|
|---|
| 240 | # (level 0) to final block (level n, not to exceed 2)
|
|---|
| 241 | # Take a reference to a hash, and stuff it full of blacklisting goodness.
|
|---|
| 242 | # Optionally accept a level, block-container, and OOB block and org arguments for
|
|---|
| 243 | # the container to check and return
|
|---|
| 244 | # Returns no value directly
|
|---|
| 245 | # Calls itself to walk down the tree of containers
|
|---|
| 246 | sub export {
|
|---|
| 247 | my $self = shift;
|
|---|
| 248 | my $listhosts = shift;
|
|---|
| 249 |
|
|---|
| 250 | # Export data as CIDR netblocks or classful (A/B/C) blocks
|
|---|
| 251 | # Assume classful as it's more compatible with different DNS servers
|
|---|
| 252 | my $mode = shift || 'class';
|
|---|
| 253 |
|
|---|
| 254 | # Assume we're checking the whole enchilada if we don't get told where to look.
|
|---|
| 255 | my $level = shift || 0;
|
|---|
| 256 | my $container = shift || '0.0.0.0/0';
|
|---|
| 257 | my $oobblock = shift || 0;
|
|---|
| 258 | my $ooborg = shift || 0;
|
|---|
| 259 |
|
|---|
| 260 | if ($level > 3) {
|
|---|
| 261 | warn "getting too deep, breaking off! ($container, $level)\n";
|
|---|
| 262 | return;
|
|---|
| 263 | }
|
|---|
| 264 |
|
|---|
| 265 | # fiddle $container into a sane state.
|
|---|
| 266 | if ($container =~ m|^\d+\.\d+\.\d+/\d+$|) {
|
|---|
| 267 | $container =~ s|/(\d+)$|.0/$1|;
|
|---|
| 268 | } elsif ($container =~ m|^\d+\.\d+/\d+$|) {
|
|---|
| 269 | $container =~ s|/(\d+)$|.0.0/$1|;
|
|---|
| 270 | } elsif ($container =~ m|^\d+/(\d+)$|) {
|
|---|
| 271 | $container =~ s|/(\d+)$|.0.0.0/$1|;
|
|---|
| 272 | }
|
|---|
| 273 |
|
|---|
| 274 | my $sth = $dbh->prepare("SELECT count(*) FROM blocks WHERE block << ?");
|
|---|
| 275 | $sth->execute($container);
|
|---|
| 276 | my ($nblocks) = $sth->fetchrow_array();
|
|---|
| 277 |
|
|---|
| 278 | if ($nblocks > 0) {
|
|---|
| 279 | my $sql = "SELECT b.block,b.listme,o.orgname,o.listme ".
|
|---|
| 280 | "FROM blocks b INNER JOIN orgs o ON b.orgid=o.orgid ".
|
|---|
| 281 | "WHERE b.level=$level and b.block << '$container' ORDER BY b.block, masklen(b.block) DESC";
|
|---|
| 282 | $sth = $dbh->prepare($sql);
|
|---|
| 283 | $sth->execute();
|
|---|
| 284 | while (my ($cidr,$listblock,$org,$listorg) = $sth->fetchrow_array()) {
|
|---|
| 285 | $self->export($listhosts,$mode,$level+1,$cidr,$listblock,$listorg);
|
|---|
| 286 | }
|
|---|
| 287 | } # avoid checking content of subs if we don't have any
|
|---|
| 288 |
|
|---|
| 289 | # don't check all 4.2 billion IPs individually if we're looking at all teh Intarwebs
|
|---|
| 290 | return if $container eq '0.0.0.0/0';
|
|---|
| 291 |
|
|---|
| 292 | ##fixme: need a way to dig out orphan IPs at all levels - IPs not found in a
|
|---|
| 293 | # subblock of the current container when the current container *has* subblocks
|
|---|
| 294 | # NB: this may be better handled as an out-of-band data-integrity-checker
|
|---|
| 295 |
|
|---|
| 296 | # decrement level here so the right bitfield setting gets picked. this segment
|
|---|
| 297 | # is inherently off-by-one from the block-recursion loop, and I can't see a
|
|---|
| 298 | # better way to work around that. >:(
|
|---|
| 299 | $level--;
|
|---|
| 300 |
|
|---|
| 301 | # need this for a bunch of things, may as well do it here
|
|---|
| 302 | my ($masklen) = ($container =~ m|/(\d+)$|);
|
|---|
| 303 |
|
|---|
| 304 | # Snag all parent block "is-it-listed?" data, and stuff it into a single
|
|---|
| 305 | # variable we can use later. Much faster than retrieving this data
|
|---|
| 306 | # individually, for each octet iteration.
|
|---|
| 307 |
|
|---|
| 308 | my $mycount = 0;
|
|---|
| 309 | my $sql = "SELECT count(i.ip),b.block,b.level,b.listme AS oobblock,o.listme AS ooborg ".
|
|---|
| 310 | "FROM iplist i INNER JOIN blocks b ON i.ip << b.block INNER JOIN orgs o ON b.orgid = o.orgid ".
|
|---|
| 311 | "WHERE b.block >>= ? ".
|
|---|
| 312 | "GROUP BY b.block,b.level,b.listme,o.listme ORDER BY b.block";
|
|---|
| 313 | my $parsth = $dbh->prepare($sql);
|
|---|
| 314 | $parsth->execute($container);
|
|---|
| 315 | my $pdata = 0;
|
|---|
| 316 | while (my ($pcount,$p,$plev,$pblock,$porg) = $parsth->fetchrow_array) {
|
|---|
| 317 | my ($pmasklen) = ($p =~ m|\d+/(\d+)$|);
|
|---|
| 318 | $pdata |= $bitfields{$plev} if $pcount >= $autolist{$pmasklen};
|
|---|
| 319 | $pdata |= $bitfields{block} if $pblock;
|
|---|
| 320 | $pdata |= $bitfields{org} if $porg;
|
|---|
| 321 | $mycount = $pcount if $p eq $container;
|
|---|
| 322 | }
|
|---|
| 323 |
|
|---|
| 324 | if ($mode eq 'cidr') {
|
|---|
| 325 | $listhosts->{$container} |= $pdata if $pdata && ($ooborg || $oobblock || ($mycount >= $autolist{$masklen}));
|
|---|
| 326 | } else {
|
|---|
| 327 | # if $cidr->masklen is <= 24, iterate on /24 boundaries for bulk sublisting
|
|---|
| 328 | # if $cidr->masklen is <= 16, iterate on /16 boundaries for bulk sublisting
|
|---|
| 329 | # if $cidr->masklen is <= 8, iterate on /8 boundaries for bulk sublisting
|
|---|
| 330 |
|
|---|
| 331 | if ($pdata) {
|
|---|
| 332 | my @blocksubs;
|
|---|
| 333 | if ($masklen <= 30 && $masklen > 24) {
|
|---|
| 334 | my ($net,$octet) = ($container =~ m|^(\d+\.\d+\.\d+\.)(\d+)/|);
|
|---|
| 335 | for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
|
|---|
| 336 | my $host = "$net$entry";
|
|---|
| 337 | $listhosts->{$host} = 0 if !defined($listhosts->{$host});
|
|---|
| 338 | $listhosts->{$host} |= $pdata;
|
|---|
| 339 | }
|
|---|
| 340 | } elsif ($masklen <= 24 && $masklen > 16) {
|
|---|
| 341 | my ($net,$octet) = ($container =~ m|^(\d+\.\d+\.)(\d+)\.\d+/|);
|
|---|
| 342 | for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
|
|---|
| 343 | my $twofour = "$net$entry.*";
|
|---|
| 344 | $listhosts->{$twofour} |= $pdata;
|
|---|
| 345 | }
|
|---|
| 346 | } elsif ($masklen <= 16 && $masklen > 8) {
|
|---|
| 347 | my ($net,$octet) = ($container =~ m|^(\d+\.)(\d+)\.\d+\.\d+/|);
|
|---|
| 348 | for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
|
|---|
| 349 | my $sixteen = "$net$entry.*";
|
|---|
| 350 | $listhosts->{$sixteen} |= $pdata;
|
|---|
| 351 | }
|
|---|
| 352 | } elsif ($masklen <= 8) {
|
|---|
| 353 | my ($octet) = ($container =~ m|^(\d+)\.\d+\.\d+\.\d+/|);
|
|---|
| 354 | for (my $entry = $octet; $entry < ($octet + $howmany[$masklen]); $entry++) {
|
|---|
| 355 | my $eight = "$entry.*";
|
|---|
| 356 | $listhosts->{$eight} |= $pdata;
|
|---|
| 357 | }
|
|---|
| 358 | }
|
|---|
| 359 |
|
|---|
| 360 | #print "DEBUG1: $container, ".(@blocksubs + 0)."\n";
|
|---|
| 361 | # this seems to be a BIG timesink... execution time ~1:30 without, ~4:30 with
|
|---|
| 362 | #if (0){
|
|---|
| 363 | # $sth = $dbh->prepare("select block,level,listme from blocks where block >> ?");
|
|---|
| 364 | # my $sth2 = $dbh->prepare("select count(*) from iplist where ip << ?");
|
|---|
| 365 | # foreach (@blocksubs) {
|
|---|
| 366 | #print " DEBUG: $_ container-is-listed check\n";
|
|---|
| 367 | # collect info on container block(s)
|
|---|
| 368 | # $sth->execute($container);
|
|---|
| 369 | # while (my ($parent, $plev, $listme) = $sth->fetchrow_array()) {
|
|---|
| 370 | # $sth2->execute($parent);
|
|---|
| 371 | # my ($parlen) = ($parent =~ m|/(\d+)|);
|
|---|
| 372 | # my ($parcount) = $sth2->fetchrow_array();
|
|---|
| 373 | #print " DEBUG: $parent: $parlen, $parcount, $plev\n";
|
|---|
| 374 | # $listhosts->{$_} |= $bitfields{$plev} if $parcount >= $autolist{$parlen}; #hmm.
|
|---|
| 375 | # $listhosts->{$_} |= $bitfields{block} if $listme;
|
|---|
| 376 | # }
|
|---|
| 377 | # }
|
|---|
| 378 | #}
|
|---|
| 379 |
|
|---|
| 380 | } # generate autolist entries for ips/octets not (yet) seen in reports
|
|---|
| 381 |
|
|---|
| 382 | } # cidr vs classful mode
|
|---|
| 383 |
|
|---|
| 384 | $sth = $dbh->prepare("SELECT ip,s4list FROM iplist WHERE ip << ? ORDER BY ip");
|
|---|
| 385 | $sth->execute($container);
|
|---|
| 386 | while (my ($ip,$moron) = $sth->fetchrow_array()) {
|
|---|
| 387 | $listhosts->{$ip} |= $pdata;
|
|---|
| 388 | if ($moron) {
|
|---|
| 389 | $listhosts->{$ip} = $bitfields{slist};
|
|---|
| 390 | } else {
|
|---|
| 391 | $listhosts->{$ip} |= $bitfields{ip};
|
|---|
| 392 | }
|
|---|
| 393 | }
|
|---|
| 394 |
|
|---|
| 395 | # get IPs which for reasons unknown are apparently allocated directly from the
|
|---|
| 396 | # parent registry (and so do not have containing netblocks in this system) O_o
|
|---|
| 397 | # select * from iplist where not (select count(*) from blocks where ip << block) > 0;
|
|---|
| 398 |
|
|---|
| 399 | return;
|
|---|
| 400 | } # end export()
|
|---|
| 401 |
|
|---|
| 402 |
|
|---|
| 403 | sub export_alt {
|
|---|
| 404 | my $self = shift;
|
|---|
| 405 | my $listhosts = shift;
|
|---|
| 406 | my $level = shift || 0;
|
|---|
| 407 | my $container = shift || '0.0.0.0/0';
|
|---|
| 408 | my $oobblock = shift || 0;
|
|---|
| 409 | my $ooborg = shift || 0;
|
|---|
| 410 |
|
|---|
| 411 | #print "\nDEBUG: called with $level, $container, $oobblock, $ooborg\n";
|
|---|
| 412 | # if $level > 2 or $container =~ /^64\.76\./;
|
|---|
| 413 | # my %listhosts;
|
|---|
| 414 |
|
|---|
| 415 | # $level = 0 if !$level;
|
|---|
| 416 | if ($level > 3) {
|
|---|
| 417 | warn "getting too deep, breaking off!\n";
|
|---|
| 418 | return;
|
|---|
| 419 | }
|
|---|
| 420 |
|
|---|
| 421 | my $sth = $dbh->prepare("select ip,s4list from iplist order by ip");
|
|---|
| 422 | my $bsth = $dbh->prepare("select b.block,b.listme,b.level,o.listme ".
|
|---|
| 423 | "from blocks b inner join orgs o on b.orgid=o.orgid ".
|
|---|
| 424 | "where b.block >> ?");
|
|---|
| 425 | while (my ($ip,$s4list) = $sth->fetchrow_array) {
|
|---|
| 426 | $bsth->execute($ip);
|
|---|
| 427 | while (my ($block,$blisted,$blevel,$olisted) = $bsth->fetchrow_array) {
|
|---|
| 428 | $listhosts->{$ip} |= 0;
|
|---|
| 429 | }
|
|---|
| 430 | }
|
|---|
| 431 |
|
|---|
| 432 | } # end export_alt()
|
|---|
| 433 |
|
|---|
| 434 |
|
|---|
| 435 | ## DNSBL::autolist_block()
|
|---|
| 436 | # check if a block should be autolisted
|
|---|
| 437 | sub autolist_block {
|
|---|
| 438 | my $self = shift;
|
|---|
| 439 | my $block = shift;
|
|---|
| 440 |
|
|---|
| 441 | my $cidr = new NetAddr::IP "$block";
|
|---|
| 442 | my $sth = $dbh->prepare("select count(*) from iplist where ip << ?");
|
|---|
| 443 | $sth->execute("$cidr");
|
|---|
| 444 | my ($count) = $sth->fetchrow_array;
|
|---|
| 445 |
|
|---|
| 446 | return 1 if $count >= $autolist{$cidr->masklen};
|
|---|
| 447 | return 0;
|
|---|
| 448 | } # end autolist_block()
|
|---|
| 449 |
|
|---|
| 450 |
|
|---|
| 451 | # make Perl happy
|
|---|
| 452 | 1;
|
|---|
![(please configure the [header_logo] section in trac.ini)](/trac/dnsbl/chrome/site/your_project_logo.png){kind=logo}
