File Coverage

blib/lib/Net/Divert.pm

Criterion	Covered	Total	%
statement	10	49	20.4
branch	1	14	7.1
condition			n/a
subroutine	3	8	37.5
pod	0	3	0.0
total	14	74	18.9

#
# Copyright (c) 2001, Stephanie Wehner
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
#
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. Neither the name of the company ITSX nor the names of its contributors
#    may be used to endorse or promote products derived from this software
#    without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.
#
#
# Net::Divert - FreeBSD Divert sockets in perl
#
# $Id: Divert.pm,v 1.2 2001/07/13 13:40:31 atrak Exp $

package Net::Divert;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;

@ISA = qw(Exporter AutoLoader);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(

);

$VERSION = '0.01';

# variables
my $IP_MAXPACKET = 65535;


BEGIN {

    my (@mods,$mod);

    @mods = qw(POSIX IO::Socket IO::Select);

    for $mod (@mods) {

        unless(eval "require $mod") {
            die "Can't find required module $mod: $!\n";
        }
    }
}

sub new
{
    my $class = shift;
    my $self = {};

    bless($self, $class);

    # initialize the divert object
    $self->_init(@_);

    return($self);
}

# initialize

sub _init
{
    my $self = shift;
    my ($host, $port) = @_;

    # check if we're root
    if(POSIX::getuid() != 0) {
        die "Need to be root to create a divert socket.\n";
    }

    # record host and port
    $self->{HOST} = $host;
    $self->{PORT} = $port;

    # set the initial fwrule tag where the packet is
    # reinserted (see man divert)
    $self->{FWTAG} = 0;

    # nothing to be written now
    $self->{OUT} = -1;
    $self->{DATA} = "";

    # setup the divert socket
    $self->{SOCK} = IO::Socket::INET->new(LocalHost => $host,
                                          LocalPort => $port,
                                          Type => IO::Socket::SOCK_RAW,
                                          Proto => 'divert');

    # set autoflush
    $self->{SOCK}->autoflush(1);

    return;
}

# clean up at the end

sub DESTROY
{
    # socket cleanup will be done by IO::Socket::INET
}

# fetch data and call user supplied function, this is perhaps
# a bit overly cautious :)

sub getPackets
{
    my $self = shift;
    my $pFunc = shift;
    my ($select,$data,$fwtag,$s);

    # initialize the select object
    $select = new IO::Select($self->{SOCK});

    # get packets
    while(1) {

        # see if things still need to be written
        if($self->{OUT} == -1) {

            # check if one can read
            foreach $s ($select->can_read) {

                if($s == $self->{SOCK}) {

                    # fetch the packet
                    $fwtag = recv($s,$data,$IP_MAXPACKET,0) or
                        die "Unable to read packet: $!\n";

                    # call the user supplied function
                    &$pFunc($data,$fwtag);
                }
            }

        } else {

            # check if one can write
            foreach $s ($select->can_write) {

                if($s == $self->{SOCK}) {

                    # write outstanding packet
                    send($s,$self->{DATA},0,$self->{FWTAG}) or
                        die "Unable to write packet: $!\n";

                    # XXX robustness

                    $self->{OUT} = -1 ;
                }
            }
        }

    }

    return;
}

# put a packet back on track, that'll be written next

sub putPacket
{
    my $self = shift;

    $self->{DATA} = shift;
    $self->{FWTAG} = shift;
    $self->{OUT} = $self->{SOCK};

    return;
}

1;
__END__