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


line stmt bran cond sub pod time code
1 1     1   1014 use strict;
  1         2  
  1         31  
2 1     1   5 use warnings;
  1         2  
  1         36  
3              
4             package Net::IMP::Example::IRCShout;
5 1     1   6 use base 'Net::IMP::Base';
  1         1  
  1         151  
6             use fields (
7 1         5 'pos', # current position in stream
8             'line', # buffer for unfinished lines
9 1     1   8 );
  1         2  
10              
11 1     1   60 use Net::IMP; # import IMP_ constants
  1         2  
  1         110  
12 1     1   7 use Net::IMP::Debug;
  1         2  
  1         7  
13 1     1   5 use Carp 'croak';
  1         2  
  1         546  
14              
15             sub INTERFACE {
16             return ([
17 0     0 0   IMP_DATA_STREAM,
18             [ IMP_PASS, IMP_REPLACE ]
19             ])
20             }
21              
22              
23             # create new analyzer object
24             sub new_analyzer {
25 0     0 1   my ($factory,%args) = @_;
26 0           my $self = $factory->SUPER::new_analyzer(%args);
27              
28 0           $self->run_callback(
29             # we are not interested in data from server
30             [ IMP_PASS, 1, IMP_MAXOFFSET ],
31             );
32              
33 0           $self->{line} = '';
34 0           $self->{pos} = 0;
35 0           return $self;
36             }
37              
38             sub data {
39 0     0 1   my ($self,$dir,$data) = @_;
40 0 0         return if $dir == 1; # should not happen
41 0 0         if ( $data eq '' ) {
42             # eof
43 0           $self->run_callback([ IMP_PASS,0,IMP_MAXOFFSET ]);
44 0           return;
45             }
46              
47 0           $self->{line} .= $data;
48              
49 0           my @rv;
50 0           while ( $self->{line} =~s{\A([^\n]*\n)}{} ) {
51 0           my $line = $1;
52 0           $self->{pos} += length($line);
53 0 0         if ( shout(\$line)) {
54 0 0 0       if ( @rv and $rv[-1][0] == IMP_REPLACE ) {
55             # update last replacement
56 0           $rv[-1][2] = $self->{pos};
57 0           $rv[-1][3].= $line;
58             } else {
59             # add new replacement
60 0           push @rv, [ IMP_REPLACE,0,$self->{pos},$line ];
61             }
62             } else {
63 0 0 0       if ( @rv and $rv[-1][0] == IMP_PASS ) {
64             # update last pass
65 0           $rv[-1][2] = $self->{pos};
66             } else {
67             # add new pass
68 0           push @rv, [ IMP_PASS,0,$self->{pos} ];
69             }
70             }
71             }
72 0 0         $self->run_callback(@rv) if @rv;
73             }
74              
75              
76             sub shout {
77 0     0 0   my $line = shift;
78 0           return $$line =~s{\A
79             (
80             (?: :\S+\x20+ )? # opt msg prefix
81             PRIVMSG\x20+\S+\x20+ # privmsg rcpt
82             )
83             (.+) # message
84             }{$1\U$2}x # shout message
85             }
86              
87             1;
88              
89             __END__