File Coverage

blib/lib/DNS/BL/cmds/punch.pm

Criterion	Covered	Total	%
statement	27	54	50.0
branch	0	18	0.0
condition	0	3	0.0
subroutine	9	10	90.0
pod	1	1	100.0
total	37	86	43.0

package DNS::BL::cmds::punch;

use DNS::BL;

use 5.006001;
use strict;
use warnings;

use NetAddr::IP;
use DNS::BL::cmds;
use DNS::BL::Entry;

use vars qw/@ISA/;

@ISA = qw/DNS::BL::cmds/;

use Carp;

our $VERSION = '0.00_01';
$VERSION = eval $VERSION;  # see L

# Preloaded methods go here.

=pod

=head1 NAME

DNS::BL::cmds::punch - Punch holes in entries within the database

=head1 SYNOPSIS

  use DNS::BL::cmds::punch;

=head1 DESCRIPTION

This module implements the B command, used to punch holes in
existing DNSBL entries managed by L. The general syntax of
this command, is as follows

    punch hole

where each argument has the following function:

=over 4

=item Bip-addressE>

Specifies which IP address or network this command refers
to. Essentially, anything that L will understand. Entries
falling entirely within this range, will be deleted. Entries that
partially overlap with the given range, will be fragmented.

=back

This functionality is provided by the following method:

=over

=item C<-Eexecute()>

See L for information on this method's general purpose
and calling convention.

This method implements the behavior specified above.

=cut

sub execute
{
    my $bl	= shift;
    my $command	= shift;
    my %args	= @_;

    my @r = __PACKAGE__->arg_check($bl, 'punch', $command,
		       [ qw/hole/ ], \%args);
    return wantarray ? (@r) : $r[0]
	if $r[0] != &DNS::BL::DNSBL_OK;

    my $e = new DNS::BL::Entry;
    my $ip;

    return wantarray ?
	(&DNS::BL::DNSBL_ESYNTAX(),
	 "'punch' requires a valid 'hole' IP address")
	: &DNS::BL::DNSBL_ESYNTAX()
	unless exists $args{hole} and
	$ip = new NetAddr::IP $args{hole};

    $e->addr($args{hole});

    # First, find out wether any space is covered by our hole. In
    # this case, remove it

    @r = $bl->erase($e);

    # Now, find entries that cover our hole.

    @r = $bl->match($e);
    shift @r;
    shift @r;

    # For each entry, split it progressively...
    while (my $r = shift @r)
    {
	my @t = $bl->erase($r);
	if ($r->addr->masklen < $e->addr->masklen)
	{			# Split and keep...
	    my @p = $r->addr->split($r->addr->masklen + 1);
	    for my $p (@p)
	    {
		if ($p->contains($e->addr))
		{
		    my $c = $r->clone;
		    $c->addr($p);
		    push @r, $c;
		}
		else
		{
		    my $c = $r->clone;
		    $c->addr($p);
		    my @t = $bl->write($c);
		    return wantarray ?
			($t[0], "'" . __PACKAGE__
			 . "' failed on add $p (" . $r->addr
			 . " dropped): $t[1]") : $t[0]
			 if $t[0] != &DNS::BL::DNSBL_OK;
		}
	    }
	}
    }

    return wantarray ? (&DNS::BL::DNSBL_OK, "Hole punched") :
	&DNS::BL::DNSBL_OK;
};

1;
__END__