#!/usr/bin/perl
#Copyright 2003 William Stearns <wstearns@pobox.com>
#Released under the GPL
#Version 0.2.3

#Usage: dibs.pl [IP of collector]

#This captures all icmp type 3 (unreachable) packets and sends them to
#the sole IP address listed on the command line.  (Support for >1
#collector to be added later).  This provides the ICMP BCC facility
#needed for the DIBS project at
#http://www.ists.dartmouth.edu/cstrc/projects/dibs.php .  No kernel
#modifications are required.  This has been tested on Linux, but should
#have no problems running on any platform with perl.
#Requires perl-Net-RawIP; see http://www.stearns.org/perl/ for RPMs or
#http://www.cpan.org for source.

use strict;
use warnings;

use Net::RawIP qw(:pcap);

my $OnePacket = new Net::RawIP({icmp => {}});	#icmp=>{} needed to extract icmp values from it later


my $Device =		"eth0";
my $BPFilter =		"proto \\icmp and icmp[0]=3";
my $Snaplen =		1500;
my $Timeout =		-1;

my $Collector;

my $PacketsToProcess =	-1;	#All

if ($Collector = shift) {
	print "BCC'ing unreachables to $Collector\n";
	$BPFilter = "$BPFilter and not dst host $Collector";
} else {
	die "I need a Collector IP address on the command line.\n";
}

my $pcap = $OnePacket->pcapinit($Device,$BPFilter,$Snaplen,$Timeout);

loop $pcap, $PacketsToProcess, \&Bcc, $OnePacket;

sub Bcc {
	$OnePacket->bset(substr($_[2],14));

	my $OneBCC = new Net::RawIP({icmp => {} });

	my ($Tos, $Saddr) = $OnePacket->get({ ip => [qw(tos saddr)] });
	my ($Type, $Code, $Payload) = $OnePacket->get({ icmp => [qw(type code data)]});

	$OneBCC -> set ( { ip => { tos => $Tos, saddr => $Saddr, daddr => $Collector },
	                   icmp => { type => $Type, code => $Code, data => $Payload } } );

	$OneBCC -> send;

	#Many thanks to Jay Beale for figuring out why I was leaking file descriptors!
	$OneBCC -> DESTROY;
}