File Coverage

blib/lib/Net/IMP.pm

Criterion	Covered	Total	%
statement	127	134	94.7
branch	8	16	50.0
condition	2	6	33.3
subroutine	35	37	94.5
pod	0	2	0.0
total	172	195	88.2

use strict;
use warnings;

package Net::IMP;
our $VERSION = '0.635';

use Carp 'croak';
use Scalar::Util 'dualvar';

# map set_debug into local namespace for convinience, so that one
# can call Net::IMP->set_debug instead of Net::IMP::Debug->set_debug
use Net::IMP::Debug 'set_debug';

use Exporter 'import';
our @EXPORT = qw(
    IMP_PASS
    IMP_PASS_PATTERN
    IMP_PREPASS
    IMP_DENY
    IMP_DROP
    IMP_TOSENDER
    IMP_REPLACE
    IMP_REPLACE_LATER
    IMP_PAUSE
    IMP_CONTINUE
    IMP_LOG
    IMP_PORT_OPEN
    IMP_PORT_CLOSE
    IMP_ACCTFIELD
    IMP_FATAL
    IMP_MAXOFFSET
    IMP_DATA_STREAM
    IMP_DATA_PACKET
);

my @log_levels = qw(
    IMP_LOG_DEBUG
    IMP_LOG_INFO
    IMP_LOG_NOTICE
    IMP_LOG_WARNING
    IMP_LOG_ERR
    IMP_LOG_CRIT
    IMP_LOG_ALERT
    IMP_LOG_EMERG
);
our @EXPORT_OK = (@log_levels, 'IMP_DATA','IMP_DATA_TYPES', 'IMP_PASS_IF_BUSY');
our %EXPORT_TAGS = ( log => \@log_levels );

# data types/protocols
# These two are the basic types, more application specific types might
# be defined somewhere else and be mapped to a number within supported_dtypes.
# The only important thing is, that streaming data should be <0, while
# packetized data (like HTTP header or UDP datagrams) should be > 0
# If no explicit type is given in sub data, it will assume IMP_DATA_STREAM.
use constant IMP_DATA_STREAM  => dualvar(-1,'imp.data.stream');
use constant IMP_DATA_PACKET  => dualvar(+1,'imp.data.packet');


# the numerical order of the constants describes priority when
# cascading modules, e.g. replacement has a higher value then
# pass and gets thus forwarded as the cause for the data

### information only
use constant IMP_LOG          => dualvar(0x0001,"log");
use constant IMP_PORT_OPEN    => dualvar(0x0002,"port_open");
use constant IMP_PORT_CLOSE   => dualvar(0x0003,"port_close");
use constant IMP_ACCTFIELD    => dualvar(0x0004,"acctfield");
### flow control
use constant IMP_PAUSE        => dualvar(0x0010,"pause");
use constant IMP_CONTINUE     => dualvar(0x0011,"continue");
use constant IMP_REPLACE_LATER  => dualvar(0x0012,"replace_later");
### keep data
use constant IMP_PASS         => dualvar(0x1001,"pass");
use constant IMP_PASS_PATTERN => dualvar(0x1002,"pass_pattern");
use constant IMP_PREPASS      => dualvar(0x1003,"prepass");
### change data
use constant IMP_TOSENDER     => dualvar(0x1010,"tosender");
use constant IMP_REPLACE      => dualvar(0x1011,"replace");
### affect whole connection
use constant IMP_DENY         => dualvar(0x1100,"deny");
use constant IMP_DROP         => dualvar(0x1101,"drop");
use constant IMP_FATAL        => dualvar(0x1102,"fatal");

# these return values still get sent if the data provider is busy
# the most important are on top
use constant IMP_PASS_IF_BUSY => [
    IMP_FATAL,
    IMP_DENY,
    IMP_DROP,
    IMP_PAUSE,
    IMP_CONTINUE,
    IMP_ACCTFIELD
];


# marker for (pre)pass to Infinite for IMP_PASS, IMP_PREPASS
use constant IMP_MAXOFFSET    => -1;

# log levels for IMP_LOG
# these are modeled analog to syslog levels
use constant IMP_LOG_DEBUG    => dualvar(1,'debug');
use constant IMP_LOG_INFO     => dualvar(2,'info');
use constant IMP_LOG_NOTICE   => dualvar(3,'notice');
use constant IMP_LOG_WARNING  => dualvar(4,'warning');
use constant IMP_LOG_ERR      => dualvar(5,'error');
use constant IMP_LOG_CRIT     => dualvar(6,'critical');
use constant IMP_LOG_ALERT    => dualvar(7,'alert');
use constant IMP_LOG_EMERG    => dualvar(8,'emergency');


# helper function to define new IMP_DATA_* types for protocols
{
    my @dualvars = ( IMP_DATA_STREAM, IMP_DATA_PACKET );
    sub IMP_DATA_TYPES { return @dualvars }

    my %atoi = map {( "$_" => $_+0 )} @dualvars;
    my %itoa = map {( $_+0 => "$_" )} @dualvars;

    # $basename - name which gets used in constant name, e.g. 'http' makes
    # IMP_DATA_HTTP_..... Best would be name of IP service.
    # - if name[number] will use number as base type number
    # - if name[other_name+number] will base types on already defined
    #   types with number added as offset
    # - if no number given it will use port name from getservbyname,
    #   multiplied with 0x10000 and die if no such service is defined
    # @def: list of defname => [+-]offset which will result in a definition
    # of IMP_DATA_BASENAME_DEFNAME => [+-](base+offset), e.g. '+' for packet
    # types and '-' for stream types
    sub IMP_DATA {
	my ($basename,@def) = @_;
	my $basenum;
	if ( $basename =~s{\[(?:(\w+)\+)?(\d+)\]$}{} ) {
	    (my $base,$basenum) = ($1,$2);
	    if ( $base ) {
		my $offset = $atoi{$base}
		    or croak("cannot find base type $base");
		$basenum += $offset;
	    }
	} else {
	    $basenum = getservbyname($basename,'tcp' )
		|| getservbyname($basename,'udp' )
		or croak("cannot determine id for $basename");
	    $basenum = $basenum << 16;
	}

	my @const;

	my $pkg = caller;
	unshift(@def,'',0);
	while (@def) {
	    my $name = shift(@def);
	    my $diff = shift(@def);
	    my $lname = $name ne '' ? "$basename.$name" : $basename;
	    croak("$lname already defined") if exists $atoi{$lname};
	    my $lnum  = $diff>=0 ? $basenum + $diff : -$basenum+$diff;
	    if ( my $s = $itoa{$lnum} || $itoa{-$lnum} ) {
		croak("id $lnum alreday used for $s");
	    }
	    $atoi{$lname} = $lnum;
	    $itoa{$lnum} = $lname;

	    my $string = "imp.data.$lname";
	    ( my $const = uc($string) )=~s{\.}{_}g;
	    push @const,$const;

	    no strict 'refs';
	    my $var = dualvar($lnum,$string);
	    *{ "${pkg}::$const" } = sub () { $var };
	    push @dualvars, $var;
	}

	return @const;
    }

}


1;

__END__