File Coverage

blib/lib/Net/IMP/Example/IRCShout.pm

Criterion	Covered	Total	%
statement	21	49	42.8
branch	0	12	0.0
condition	0	6	0.0
subroutine	7	11	63.6
pod	2	4	50.0
total	30	82	36.5

use strict;
use warnings;

package Net::IMP::Example::IRCShout;
use base 'Net::IMP::Base';
use fields (
    'pos',   # current position in stream
    'line',  # buffer for unfinished lines
);

use Net::IMP; # import IMP_ constants
use Net::IMP::Debug;
use Carp 'croak';

sub INTERFACE {
    return ([
	IMP_DATA_STREAM,
	[ IMP_PASS, IMP_REPLACE ]
    ])
}


# create new analyzer object
sub new_analyzer {
    my ($factory,%args) = @_;
    my $self = $factory->SUPER::new_analyzer(%args);

    $self->run_callback(
	# we are not interested in data from server
	[ IMP_PASS, 1, IMP_MAXOFFSET ],
    );

    $self->{line} = '';
    $self->{pos} = 0;
    return $self;
}

sub data {
    my ($self,$dir,$data) = @_;
    return if $dir == 1; # should not happen
    if ( $data eq '' ) {
	# eof
	$self->run_callback([ IMP_PASS,0,IMP_MAXOFFSET ]);
	return;
    }

    $self->{line} .= $data;

    my @rv;
    while ( $self->{line} =~s{\A([^\n]*\n)}{} ) {
	my $line = $1;
	$self->{pos} += length($line);
	if ( shout(\$line)) {
	    if ( @rv and $rv[-1][0] == IMP_REPLACE ) {
		# update last replacement
		$rv[-1][2] = $self->{pos};
		$rv[-1][3].= $line;
	    } else {
		# add new replacement
		push @rv, [ IMP_REPLACE,0,$self->{pos},$line ];
	    }
	} else {
	    if ( @rv and $rv[-1][0] == IMP_PASS ) {
		# update last pass
		$rv[-1][2] = $self->{pos};
	    } else {
		# add new pass
		push @rv, [ IMP_PASS,0,$self->{pos} ];
	    }
	}
    }
    $self->run_callback(@rv) if @rv;
}


sub shout {
    my $line = shift;
    return $$line =~s{\A
	(
	    (?: :\S+\x20+ )?      # opt msg prefix
	    PRIVMSG\x20+\S+\x20+  # privmsg rcpt
	)
	(.+)                      # message
    }{$1\U$2}x                    # shout message
}

1;

__END__