#!/usr/bin/perl -swl-

# ----------------------------------------------------------
# 			 rbldnspack
# 
# 		       Meng Weng Wong
# 		Mon Sep 10 17:10:30 EDT 2001
#     http://www.mengwong.com/software/perl/rbldnspack
# 
# $Id: packnetblock,v 1.3 2001/09/20 14:55:37 mengwong Exp mengwong $
# accessory program for axfr2rbldns
# 
# usage: packnetblock [-d] [-lessthan8isok] < data.rbl
# 
# see also Net::CIDR::Lite
# 
# as received from rbl-plus.mail-abuse.org, contiguous CIDR
# ranges are divided into traditional network class A/B/C
# segments.  this program condenses multiple consecutive
# segments into CIDR network ranges.
# 
# for instance,
# 127.0.0.1/24 and
# 127.0.0.2/24 would be squished into 
# 127.0.0.1/23.
# 
# license: GPL
# 
# see:
#     http://www.djbdns.org/
#     http://cr.yp.to/djbdns.html
#     http://cr.yp.to/djbdns/axfr-get.html
#     http://cr.yp.to/djbdns/rbldns-data.html
#     http://www.mail-abuse.org/rbl+/
#     http://www.spin.it/furio/rblplus-postfix.html
#     http://www.kfki.hu/~kadlec/sw/postfix_patch.html
# 
#  perl -MSocket -le 'my $n = unpack "N*", inet_aton("127.0.0.1"); print $n; $n=$n<<1; print $n; print unpack "B*", pack "N*", $n'
# 
# algorithm:
#   build a list of netblocks.  sort the netblocks.
#   start the pointer at the top of the list and sink downwards.
#   if the netblocks immediately above and below the pointer
#   have the same cidr value and are continguous, pack them together.  leave the pointer above the result.
#   if not, move the pointer down.
# ---------------------------------------------------------

# ----------------------------------------------------------
# 		       functions
# ----------------------------------------------------------

sub show { unpack "B*", pack "N*", shift }
sub display { my $netblock = shift; sprintf ("    %s:\n%40s\n%40s",
					     "$netblock->[1]/$netblock->[2]",
					     show($netblock->[0]),
					     show((2**32)-1 << (32-$netblock->[2]))); }

# ----------------------------------------------------------
# 	 no user-serviceable parts below this line
# ----------------------------------------------------------

use strict; use Socket;
use vars qw($d $v $lessthan8isok); $d ||= $v;

# ----------------------------------------------------------
#			    main
# ----------------------------------------------------------

my @netblocks;

while (<>) {
    chomp; next if not length;

    my $firstchar = ord(substr($_, 0, 1));	
    print and next unless $firstchar >= ord(0) and $firstchar <= ord(9);

    my $cidrmask = 32;
    my $ip = $_;

    if ((my $slash_index = index($_, "/")) >= 0) {       $ip = substr($_, 0, $slash_index    );
						   $cidrmask = substr($_,    $slash_index + 1);
						 }

    push @netblocks, [unpack ("N*", inet_aton($ip)), $ip, $cidrmask];
    $0 = "packnetblock: read @{[scalar @netblocks]} netblocks" if @netblocks % 100 == 0;
}

$0 = "packnetblock: sorting @{[scalar @netblocks]} netblocks";
@netblocks = sort { $a->[0] <=> $b->[0] } @netblocks;

if ($d) { print STDERR "input:"; foreach my $netblock (@netblocks) {    print STDERR display($netblock);} }

# 
# data structure:
#   [netblock,   ip,          cidrmask]
#   [2130706433, "127.0.0.1", 24,     ]
# 

my $i = 0;
while ($i < $#netblocks) {
    $0 = sprintf "packnetblock: %d%% done (pondering position $i/$#netblocks)", $i*100/$#netblocks if $i % 100 == 0;

    if ($d) {
	print STDERR "";
	print STDERR "*** pointer at netblock $i:";
	print STDERR display ($netblocks[$i]);
	print STDERR display ($netblocks[$i+1]);
    }

    if ($netblocks[$i]->[2] != $netblocks[$i+1]->[2]) { # netblocks have different netmasks
	$d and print STDERR ">>> netblocks have different netmasks.  advancing pointer.";

	$i++; next;
    }

    my $oldcidrmask  = $netblocks[$i]->[2];
    my $oldnetmask   = (2**32-1) << (32 - $oldcidrmask);

    # are these domains overlapping?
    if (($netblocks[$i+0]->[0] & $oldnetmask) ==
	($netblocks[$i+1]->[0] & $oldnetmask)) {
	print STDERR "!!! overlap found!";
	print STDERR display ($netblocks[$i]);
	print STDERR display ($netblocks[$i+1]);
	$i++; next;
    }

    my $newcidrmask  = $oldcidrmask - 1;

    # rbldns doesn't want to see cidr /N of N<8.
    if ($newcidrmask < 8 and not $lessthan8isok) { $i++; next }

    # are netblocks contiguous?
    my $netmask_shifted = $oldnetmask << 1;

    if ($d) {
#    my $a_trunced = $netblocks[$i+0]->[0] & $netmask_shifted;
#    my $b_trunced = $netblocks[$i+1]->[0] & $netmask_shifted;
#	print STDERR "";
#       print STDERR "new netmask:". " "x10 . show($netmask_shifted);
#       print STDERR "new first:            " . show ($a_trunced);
#       print STDERR "new second:           " . show ($b_trunced);
    }

    if (($netblocks[$i+0]->[0] & $netmask_shifted) ==
	($netblocks[$i+1]->[0] & $netmask_shifted)) {

	$netblocks[$i] = [$netblocks[$i]->[0],
			  $netblocks[$i]->[1],
			  $newcidrmask];
	
	if ($d) {
	    print STDERR "*** netblocks are contiguous!  joining them.";
	    print STDERR "    result:";
	    print STDERR display($netblocks[$i]);
	}

	# todo: this would probably go a whole lot faster if we didn't splice in place
	# but instead created a new output list, where the action happened only at the tail.
	splice(@netblocks, $i+1, 1, ());

	if ($i>0) { $i--;
		    $d and print STDERR "*** backing up to position $i";
		    next;
		}
    }
    else {
	if ($d) { print STDERR ">>> no good.  advancing pointer."; }
	$i++;
	next;
    }
}

$0 = "packnetblock: writing output: @{[scalar @netblocks]} netblocks";

for (@netblocks) {
    if ($_->[2] != 32) { print "$_->[1]/$_->[2]"; }
    else               { print "$_->[1]"; }
}