use strict;
use warnings;
package Net::IMP::Filter;
use fields qw(imp buf passed topass prepass skipped eof);
use Net::IMP;
use Net::IMP::Debug;


############################################################################
#  these need to be redefined in subclass
############################################################################
# analyzed data output
sub out {
    my ($self,$dir,$data) = @_;
    return;
}

sub deny {
    my ($self,$msg,$dir) = @_;
    $DEBUG && debug("deny $msg");
    return;
}

sub log {
    my ($self,$level,$msg,$dir,$offset,$len) = @_;
    $DEBUG && debug("log [$level] $msg");
    return;
}

sub acctfld {
    my ($self,$key,$value) = @_;
    $DEBUG && debug("acctfld $key=$value");
    return;
}

############################################################################
#  Implementation
############################################################################
sub new {
    my ($class,$imp) = @_;
    my $self = fields::new($class);
    %$self = (
	imp   => $imp,
	buf     => ['',''],
	passed  => [0,0], # offset of buf in input stream
	topass  => [0,0], # may pass up to this offset
	prepass => [0,0], # flag if topass means prepass, not pass
	skipped => [0,0], # flag if last data got not send to analyzer
			  # because of pass into future
	eof     => 0,     # bitmask set inside output
    );
    $imp->set_callback(\&_imp_cb,$self) if $imp;
    return $self;
}

# data into analyzer
sub in {
    my ($self,$dir,$data) = @_;
    return _out($self,$dir,$data) if ! $self->{imp};

    $DEBUG && debug("in($dir) %d bytes",length($data));

    # (pre)pass w/o analyzing (first)
    if ( $self->{topass}[$dir] == IMP_MAXOFFSET ) {
	$DEBUG && debug("can (pre)pass w/o analyzing (first) ".
	    "topass=MAX passed=$self->{passed}[$dir] l=".
	    length($data));
	# (pre)pass in future
	$self->{buf}[$dir] eq '' or die "buf should be empty";
	$self->{passed}[$dir] += length($data);
	_out($self,$dir,$data);
	if ( $self->{prepass}[$dir] ) {
	    $self->{imp}->data($dir,$data)
	} elsif ( $data ne '' ) {
	    $self->{skipped}[$dir] = 1;
	}
	$data = '';
	return; # everything passed
    } elsif (( my $diff = $self->{topass}[$dir]-$self->{passed}[$dir] ) > 0 ) {
	$DEBUG && debug("can (pre)pass w/o analyzing (first) diff=$diff ".
	    "topass=$self->{topass}[$dir] passed=$self->{passed}[$dir] l=".
	    length($data));
	# (pre)pass in future
	$self->{buf}[$dir] eq '' or die "buf should be empty";
	my $out = substr($data,0,$diff,'');
	$self->{passed}[$dir] += length($out);
	_out($self,$dir,$out);
	if ( $self->{prepass}[$dir] ) {
	    $self->{imp}->data($dir,$out)
	} elsif ( $out ne '' ) {
	    $self->{skipped}[$dir] = 1;
	}
	return if $data eq ''; # everything passed
    }

    # forward data or eof
    $self->{buf}[$dir] .= $data;
    if ( $self->{skipped}[$dir] ) {
	$DEBUG && debug("fwd($dir) %d bytes offset=%d",
	    length($data),$self->{passed}[$dir]);
	$self->{imp}->data($dir,$data,$self->{passed}[$dir]);
    } else {
	$DEBUG && debug("fwd($dir) %d bytes",length($data));
	$self->{imp}->data($dir,$data);
    }
}

# callback from analyzer
sub _imp_cb {
    my $self = shift;

    for my $rv (@_) {
	my $rtype = shift(@$rv);
	$DEBUG && debug("$rtype ".join(" ",map { "'$_'" } @$rv));

	if ( $rtype == IMP_DENY ) {
	    my ($dir,$msg) = @$rv;
	    $self->deny($msg,$dir);
	    return;

	} elsif ( $rtype == IMP_LOG ) {
	    my ($dir,$offset,$len,$level,$msg) = @$rv;
	    $self->log($level,$msg,$dir,$offset,$len);

	} elsif ( $rtype == IMP_ACCTFIELD ) {
	    my ($key,$value) = @$rv;
	    $self->acctfld($key,$value);

	} elsif ( $rtype ~~ [ IMP_PASS, IMP_PREPASS, IMP_REPLACE ] ) {
	    my ($dir,$offset,$newdata) = @$rv;
	    $DEBUG && debug("got %s %d|%d passed=%d inbuf=%d",
		$rtype,$dir,$offset,$self->{passed}[$dir],
		length($self->{buf}[$dir]));

	    my $fwd = length($self->{buf}[$dir]);
	    if ( $offset != IMP_MAXOFFSET ) {
		my $diff = $offset - $self->{passed}[$dir];
		if ( $diff<0 ) {
		    $DEBUG && debug("diff=$diff - $rtype for already passed data");
		    # already passed
		    die "cannot replace already passed data"
			if $rtype == IMP_REPLACE;
		    next;
		}

		my $rl = $fwd;
		$fwd = $rl>$diff ? $diff: $rl;
		$DEBUG && debug("need to $rtype $fwd bytes");
		$self->{passed}[$dir]  += $fwd;

		if ( $rtype == IMP_REPLACE ) {
		    die "cannot replace not yet received data" if $rl<$diff;
		    $DEBUG && debug("buf='%s' [0,$fwd]->'%s'",
			substr($self->{buf}[$dir],0,$fwd),$newdata);
		    substr($self->{buf}[$dir],0,$fwd,$newdata);
		    $fwd = length($newdata);
		}

	    } else {
		die "cannot replace future data" if $rtype == IMP_REPLACE;
		$self->{passed}[$dir]  += $fwd;
	    }

	    $self->{topass}[$dir]  = $offset;
	    $self->{prepass}[$dir] = ($rtype == IMP_PREPASS);

	    # output accepted data
	    _out($self,$dir,substr($self->{buf}[$dir],0,$fwd,'')) if $fwd;

	} else {
	    die "cannot handle Net::IMP rtype $rtype";
	}
    }
}

sub _out {
    my ($self,$dir,$data) = @_;
    if ( $data eq '' and  3 == ($self->{eof} |= $dir ? 1:2)
	and $self->{imp}) {
	# finished connection, remove circular dependencies
	$self->{imp}->set_callback(undef);
	$self->{imp} = undef;
    }
    $self->out($dir,$data);
}

1;
__END__

=head1 NAME

Net::IMP::Filter - simple data filter using Net::IMP analyzers

=head1 SYNOPSIS

    package myFilter;
    use base 'Net::IMP::Filter';
    sub out {
	my ($self,$dir,$data) = @_;
	print "[$dir] $data\n";
    }

    package main;
    use Net::IMP::Pattern;
    my $factory = Net::IMP::Pattern->new_factory...;
    my $f = myFilter->new( $factory->new_analyzer );
    ..
    $f->in(0,$data0);
    $f->in(1,$data1);
    ..

=head1 DESCRIPTION

C<Net::IMP::Filter> is a class which can be used for simple filters (e.g. data in,
data out) using Net::IMP analyzers, thus hiding the complexity but also useful
features of the Net::IMP interface for simple use cases.
To create such a filter subclass from C<Net::IMP::Filter> and implement any of the
following methods (which by default do nothing)

=over 4

=item out($self,$dir,$data)

this gets called for output of data

=item deny($self,$msg,$dir)

this gets called on IMP_DENY

=item log($self,$level,$msg,$dir,$offset,$len)

this gets called on IMP_LOG

=item acctfld($self,$key,$value)

this gets called on IMP_ACCTFIELD

=back

=head1 AUTHOR

Steffen Ullrich <sullr@cpan.org>

=head1 COPYRIGHT

Copyright by Steffen Ullrich.

This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.