File Coverage

blib/lib/DNS/BL.pm

Criterion	Covered	Total	%
statement	93	103	90.2
branch	36	46	78.2
condition	15	15	100.0
subroutine	24	26	92.3
pod	9	9	100.0
total	177	199	88.9

package DNS::BL;

use 5.006001;
use strict;
use warnings;

use Carp;

# These constans are used to specify specific error condition / result
# codes.

=pod

=head1 NAME

DNS::BL - Manage DNS black lists

=head1 SYNOPSIS

  use DNS::BL;

=head1 DESCRIPTION

This class provides the services required to manage DNSBL data using
this module hierarchy. It does so by implementing a series of methods,
that perform the required function and when called in array context,
return a two-element list, whose first element is a return code and
its second element, is a diagnostic message.

In scalar context, only the constant is returned.

The following constants are defined:

=over

=item B

Denotes a succesful operation.

=item B

A problem related to the connection or lack of, to the backend.

=item B

When inserting entries in the backend, a previous entry conflicts with
this one.

=item B

When looking up entries in the backend, no suitable entry has been
found.

=item B

A syntax error was detected by a callback handler.

=item B

Some other kind of error.

=back

=cut

use constant DNSBL_OK		=> 0;
use constant DNSBL_ECONNECT	=> 1;
use constant DNSBL_ECOLLISSION	=> 2;
use constant DNSBL_ENOTFOUND	=> 4;
use constant DNSBL_ESYNTAX	=> 8;
use constant DNSBL_EOTHER	=> 16;

use constant ERR_MSG => "Must issue a 'connect' first";

our $VERSION = '0.03';
$VERSION = eval $VERSION;  # see L

# Preloaded methods go here.

=pod

The following methods are implemented by this module:

=over

=item C<-Enew()>

This method creates a new C object. No parameters are
required.

=cut

sub new($)
{
    my $class = shift;
    return bless
    {
	k => {},		# Storage
    }, $class;
}


=pod

=item C<-Eparse($command)>

This method tokenizes each line given in C<$command>, loading and
calling the appropiate modules to satisfy the request. As shipped,
each command verb, usually the first word of a C<$command>, will
invoke a class from the C hierarchy, which handles
such commands. A summary of those is included in
L. Likely, you can provide your own commands by
subclassing C in your own classes.

Note that this method supports comments, by prepending a pound
sign. Most Perl-ish way.

When a command is invoked for the first time, the class is
Cd. For example, the "foo" command would involve loading the
C class.

After this loading process, the class' C method is
invoked. This is documented in L.

=cut

sub parse($$)
{
    my $self = shift;
    my $comm = shift;

    $comm =~ s/^\s+//;		# Remove leading whitespace
    $comm =~ s/\s+$//;		# Remove trailing whitespace

    my @tok = ();		# List of tokens
    my $proto = undef;		# A proto-token
    my $in_string = 0;		# State: Are we within a quoted string?

    # Iterate through characters in a simple automaton

    for my $c (split //, $comm)
    {
	if ($c eq '"')
	{
	    push @tok, $proto if defined $proto || $in_string;
	    $proto = undef;
	    $in_string = ! $in_string;
	    next;
	}
	elsif ($c eq '#' and ! $in_string)
	{
	    last;
	}
	elsif ($c =~ /\s/s and ! $in_string and defined $proto)
	{
	    push @tok, $proto;
	    $proto = undef;
	}
	else
	{
	    next if $c =~ /\s/s and ! $in_string;
	    $proto .= $c;
	}
    }

    # Flag trailing quoted strings
    if ($in_string)
    {
	return wantarray?(DNSBL_ESYNTAX,
			  "End of command within a quoted string")
	    :DNSBL_ESYNTAX
    }

    # The ending token must be considered too
    push @tok, $proto if defined $proto;

    # Trivial case: An empty line...
    unless (@tok)
    {
	return wantarray?(DNSBL_OK, "-- An empty line, huh?")
	    : DNSBL_OK;
    }

    my $verb = shift @tok;

    do {
	no strict 'refs';
	unless (*{ __PACKAGE__ . "::cmds::${verb}::execute"}{CODE})
	{
	    eval "use " . __PACKAGE__ . "::cmds::${verb};";
	    if ($@)
	    {
		return wantarray?(DNSBL_ESYNTAX, "Verb $verb undefined: $@")
		    :DNSBL_ESYNTAX;
	    }
	}

	if (*{ __PACKAGE__ . "::cmds::${verb}::execute"}{CODE})
	{			# Handler exists
	    return &{ __PACKAGE__
			  . "::cmds::${verb}::execute"}($self, $verb, @tok);
	}
    };

    return wantarray?(DNSBL_ESYNTAX, "Verb $verb is undefined")
	:DNSBL_ESYNTAX;
}

=pod

=item C<-Eset($key, $value)>

Set the value of a C<$key> which is stored in the object itself, to
the scalar C<$value>.

=cut

sub set { my $ret = $_[0]->{k}->{$_[1]}; $_[0]->{k}->{$_[1]} = $_[2];
	  return $ret; }

=pod

=item C<-Eget($key)>

Retrieve the scalar value associated to the given C<$key>.

=cut

sub get { return $_[0]->{k}->{$_[1]}; }

=pod

=back

The following methods are really pointers meant to be replaced by the
L classes invoked at runtime. The specific
function of each function is discussed below (briefly) and in
L.

The L classes must replace them by using
the the accessors to store the reference to the function (or clusure),
using the same name of the method, prepending an underscore.

=over

=item C<-Eread($entry)>

Given an C<$entry>, retrieve all the L objects
contained in the IP address range denoted in its C<-Eaddr()>
method, stored in the Ced backend. Its return value, is a
list where the first element is the result code, the second is a
message suitable for diagnostics. The rest of the elements, if any,
are the matching entries found.

C<$entry> should be a L object.

=item C<-Ematch($entry)>

Given an C<$entry>, retrieve all the L objects that
contain the IP address range denoted in its C<-Eaddr()> method,
stored in the Ced backend. Its return value, is a list where
the first element is the result code, the second is a message suitable
for diagnostics. The rest of the elements, if any, are the matching
entries found.

C<$entry> should be a L object.

=item C<-Ewrite($entry)>

Store the given L object in the connected backend.

=item C<-Eerase($entry)>

Delete all the C from the connected backend, whose
C<-Eaddr()> network range falls entirely within the one given in
C<$entry>.

=item C<-Ecommit()>

Commit all the changes to the backend. In some backends this is a
no-op, but it should be invoked at the end of each command block.

=back

=cut

sub read	{ &{$_[0]->{k}->{_read}		|| *{_io}{CODE}}(@_); }
sub match	{ &{$_[0]->{k}->{_match}	|| *{_io}{CODE}}(@_); }
sub write	{ &{$_[0]->{k}->{_write}	|| *{_io}{CODE}}(@_); }
sub erase	{ &{$_[0]->{k}->{_erase}	|| *{_io}{CODE}}(@_); }
sub commit	{ &{$_[0]->{k}->{_commit}	|| *{_io}{CODE}}(@_); }
sub _io		{ wantarray?(&DNSBL_ECONNECT, &ERR_MSG):&DNSBL_ECONNECT }

sub DNS::BL::cmds::commit::execute { $_[0]->commit(@_); }

sub DNS::BL::cmds::_dump::execute
{
    use Data::Dumper;
    my $self = shift;

    print "*** Current object $self:\n";
    print Data::Dumper->Dump([$self]);

    if (@_)
    {
	print "*** Arguments:\n";
	print "  '$_'\n" for @_;
    }
    else
    {
	print "*** No arguments\n";
    }
    return wantarray ? (DNSBL_OK, "Debug dump done") : DNSBL_OK;
}

1;
__END__