File Coverage

blib/lib/Net/Inspect/Flow.pm

Criterion	Covered	Total	%
statement	26	66	39.3
branch	2	16	12.5
condition	1	3	33.3
subroutine	7	14	50.0
pod	2	3	66.6
total	38	102	37.2

############################################################################
# base class for packet flows
############################################################################

use strict;
use warnings;

package Net::Inspect::Flow;
use fields qw(upper_flow);

sub new {
    my ($class,$flow) = @_;
    if ( ! ref($class)) {
	# create new
	my $self = fields::new($class);
	$self->{upper_flow} = $flow;
	return $self;
    } else {
	my $self = fields::new(ref($class));
	$self->{upper_flow} = $flow
	    || ( $class->{upper_flow} && $class->{upper_flow}->new ); # clone
	return $self;
    }
}

sub new_any {
    shift;
    return Net::Inspect::Flow::Any->new(@_)
}

# does nothing per default
sub expire {}

package Net::Inspect::Flow::Any;
use Digest::MD5 'md5_hex';
use fields qw(flows);

sub new {
    my ($class,@methods) = @_;
    if (@methods) {
	my $clname = "Net::Inspect::Flow::Any::".
	    md5_hex(join("\0",sort @methods));
	if ( ! UNIVERSAL::can($clname,'new') ) {
	    # dynamically create class
	    eval "package $clname; use base 'Net::Inspect::Flow::Any';1"
		or die $@;
	    for my $method (@methods) {
		no strict 'refs';
		*{ "${clname}::$method" } = sub {
		    my $self = shift;
		    for my $flow (@{$self->{flows}}) {
			if ( wantarray ) {
			    my @rv = $flow->$method(@_) or next;
			    return @rv
			} else {
			    defined( my $rv = $flow->$method(@_)) or next;
			    return $rv
			}
		    }
		    return;
		};
	    }
	}
	return $clname->new;
    }


    if ( ! ref $class ) {
	my $self = fields::new($class);
	$self->{flows} = [];
	return $self
    } else {
	my $self = fields::new(ref($class));
	# clone attached flows
	$self->{flows} = [ map { $_->new } @{ $class->{flows} } ];
	return $self;
    }
}

sub attach {
    my ($self,$flow) = @_;
    push @{ $self->{flows} }, $flow;
}

sub detach {
    my ($self,$flow) = @_;
    @{ $self->{flows} } = grep { $_ != $flow } @{ $self->{flows} };
}

sub attached {
    my $self = shift;
    return @{ $self->{flows} }
}

1;

__END__