view release on metacpan or  search on metacpan

lib/Net/IMP/Pattern.pm  view on Meta::CPAN

    push @err, $class->SUPER::validate_cfg(%args);
    return @err;
}


# create new analyzer object
sub new_analyzer {
    my ($factory,%args) = @_;
    my $fargs = $factory->{factory_args};

    my $rxlen;
    my $rx = $fargs->{rx};
    if ($rx) {
	$rxlen = $fargs->{rxlen};
    } else {
	$rx = $fargs->{string};
	$rxlen = length($rx);
	$rx = qr/\Q$rx/;
    }

    my Net::IMP::Pattern $self = $factory->SUPER::new_analyzer(
	%args, # cb, meta
	rx      => $rx,
	rxlen   => $rxlen,
	rxdir   => $fargs->{rxdir},
	action  => $fargs->{action},
	actdata => $fargs->{actdata},
	buf     => ['',''],  # per direction
	buftype => [0,0],    # per direction
	offset  => [0,0],    # per direction
    );

    if ( defined $self->{rxdir} ) {
	# if rx is specified only for one direction immediatly issue PASS until
	# end for the other direction
	$self->run_callback([
	    IMP_PASS,
	    $self->{rxdir} ? 0:1,
	    IMP_MAXOFFSET,
	]);
    }

    return $self;
}

sub data {
    my Net::IMP::Pattern $self = shift;
    my ($dir,$data,$offset,$type) = @_;

    $offset and die "cannot deal with gaps in data";

    # if this is the wrong dir return, we already issued PASS
    return if defined $self->{rxdir} and $dir != $self->{rxdir};

    # accumulate results
    my @rv;

    my $buf;
    if ( $type > 0 or $type != $self->{buftype}[$dir] ) {
	# packet data or other streaming type
	$buf = $data;
	if ( $self->{buf}[$dir] ne '' ) {
	    # pass previous buffer and reset it
	    debug("reset buffer because type=$type, buftype=$self->{buftype}[$dir]");
	    $self->{offset}[$dir] += length($self->{buf}[$dir]);
	    $self->{buf}[$dir] = '';
	    push @rv, [ IMP_PASS,$dir,$self->{offset}[$dir] ];
	} elsif ( ! $self->{buftype}[$dir] and not $type > 0 ) {
	    # initial streaming buf
	    $self->{buf}[$dir] = $buf;
	}
	$self->{buftype}[$dir] = $type;
    } else {
	# streaming data, match can span multiple chunks
	$buf = ( $self->{buf}[$dir] .= $data );
    }

    $DEBUG && debug("got %d bytes $type on %d, bufsz=%d, rxlen=%d",
	length($data),$dir,length($buf),$self->{rxlen});

    # for packet types we accumulate datain newdata and set changed if newdata
    # are different from old
    my $changed = 0;
    my $newdata = '';

    while (1) {
	if ( my ($good,$match) = $buf =~m{\A(.*?)($self->{rx})}s ) {
	    # rx matched:
	    # - strip up to end of rx from buf
	    # - issue IMP_PASS for all data in front of rx
	    # - handle rx according to action
	    # - continue with buf after rx (e.g. redo loop)

	    if ( length($match)> $self->{rxlen} ) {
		# user specified a rx, which could match more than rxlen, e.g.
		# something like qr{\d+}. make sure we only match rxlen bytes
		if ( substr($match,0,$self->{rxlen}) =~m{\A($self->{rx})} ) {
		    $match = $1;
		} else {
		    # no match possible in rxlen bytes, reset match
		    # and add one char from original match to $good
		    # so that we don't try to match here again
		    $good .= substr($match,0,1);
		    $match = '';
		}
	    } else {
		# we checked in new_analyzer already that rx does not match
		# empty string, so we should be save here that rxlen>=match>0
	    }

	    if ( $good ne '' ) {
		$DEBUG && debug("pass %d bytes in front of match",
		    length($good));
		# pass everything before the match and advance offset
		$self->{offset}[$dir]+=length($good);
		if ( $type>0 ) {
		    # keep good
		    $newdata .= substr($buf,0,length($good),'');
		} else {
		    # pass good
		    push @rv, [ IMP_PASS, $dir, $self->{offset}[$dir] ];
		    substr($buf,0,length($good),'');
		}
	    }
	    # remove match
	    substr($buf,0,length($match),'');
	    $self->{offset}[$dir] += length($match);

	    if ( $match eq '' ) {
		# match got reset if >rxlen -> no action

	    # handle the matched pattern according to action
	    } elsif ( $self->{action} eq 'deny' ) {
		# deny everything after