File Coverage

blib/lib/Circle/Net/IRC/Target.pm
Criterion Covered Total %
statement 30 175 17.1
branch 0 36 0.0
condition 0 9 0.0
subroutine 10 40 25.0
pod 1 26 3.8
total 41 286 14.3


line stmt bran cond sub pod time code
1             # You may distribute under the terms of the GNU General Public License
2             #
3             # (C) Paul Evans, 2008-2014 -- leonerd@leonerd.org.uk
4              
5             package Circle::Net::IRC::Target;
6              
7 4     4   18 use strict;
  4         5  
  4         85  
8 4     4   11 use warnings;
  4         5  
  4         78  
9 4     4   11 use base qw( Tangence::Object Circle::WindowItem );
  4         5  
  4         624  
10              
11             sub new
12             {
13 0     0 0   my $class = shift;
14 0           my %args = @_;
15              
16 0           my $self = $class->SUPER::new( @_ );
17              
18 0           $self->{irc} = $args{irc};
19              
20 0           $self->set_prop_name( $args{name} );
21 0           $self->set_prop_tag( $args{name} );
22              
23 0           $self->{root} = $args{root};
24 0           $self->{net} = $args{net};
25              
26 0           return $self;
27             }
28              
29             # Convenience accessor
30             sub name
31             {
32 0     0 0   my $self = shift;
33 0           return $self->get_prop_name;
34             }
35              
36 4     4   17 use Scalar::Util qw( refaddr );
  4         6  
  4         283  
37             use overload
38             # '""' => "STRING",
39 0     0   0 '0+' => sub { refaddr $_[0] },
40 4     4   20 fallback => 1;
  4         5  
  4         45  
41              
42 4     4   246 use constant PREFIX_OVERHEAD => 3;
  4         4  
  4         186  
43 4     4   15 use constant PRIVMSG_OVERHEAD => length("PRIVMSG :");
  4         3  
  4         171  
44 4     4   12 use constant CTCP_ACTION_OVERHEAD => length("PRIVMSG :\x01CTCP ACTION \x01");
  4         8  
  4         5144  
45              
46             sub STRING
47             {
48 0     0 0   my $self = shift;
49 0           return ref($self)."[name=".$self->name."]";
50             }
51              
52             sub describe
53             {
54 0     0 1   my $self = shift;
55 0           return ref($self) . "[" . $self->name . "]";
56             }
57              
58             sub get_prop_tag
59             {
60 0     0 0   my $self = shift;
61 0           return $self->name;
62             }
63              
64             sub get_prop_network
65             {
66 0     0 0   my $self = shift;
67 0           return $self->{net};
68             }
69              
70             sub reify
71             {
72 0     0 0   my $self = shift;
73              
74 0 0         return if $self->get_prop_real;
75              
76 0           $self->set_prop_real( 1 );
77              
78 0           my $root = $self->{root};
79 0           $root->broadcast_sessions( "new_item", $self );
80             }
81              
82             sub on_message
83             {
84 0     0 0   my $self = shift;
85 0           my ( $command, $message, $hints ) = @_;
86              
87             # $command might contain spaces from synthesized events - e.g. "ctcp ACTION"
88 0           ( my $method = "on_message_$command" ) =~ s/ /_/g;
89              
90 0 0 0       return 1 if $self->can( $method ) and $self->$method( $message, $hints );
91              
92 0 0 0       if( not $hints->{handled} and not $hints->{synthesized} ) {
93             $self->push_displayevent( "irc.irc", {
94             command => $command,
95             prefix => $message->prefix,
96 0           args => join( " ", map { "'$_'" } $message->args ),
  0            
97             } );
98 0           $self->bump_level( 1 );
99             }
100              
101 0           return 1;
102             }
103              
104             sub pick_display_target
105             {
106 0     0 0   my $self = shift;
107 0           my ( $display ) = @_;
108              
109 0 0         return $self if $display eq "self";
110 0 0         return $self->{net} if $display eq "server";
111             }
112              
113             sub default_message_level
114             {
115 0     0 0   my $self = shift;
116 0           my ( $hints ) = @_;
117              
118 0 0         return $hints->{is_notice} ? 1 : 2;
119             }
120              
121             sub on_message_text
122             {
123 0     0 0   my $self = shift;
124 0           my ( $message, $hints ) = @_;
125              
126 0           my $srcnick = $hints->{prefix_name};
127 0           my $text = $hints->{text};
128              
129 0           my $is_notice = $hints->{is_notice};
130              
131 0           my $net = $self->{net};
132              
133             my $event = {
134             %$hints,
135             text => $net->format_text_tagged( $text ),
136             is_action => 0,
137             level => $self->default_message_level( $hints ),
138 0 0 0       display => ( !defined $hints->{prefix_nick} or $is_notice && !$self->get_prop_real ) ? "server" : "self",
139             };
140              
141 0           $net->run_rulechain( "input", $event );
142              
143 0 0         my $eventname = $is_notice ? "notice" : "msg";
144              
145 0           $self->fire_event( $eventname, $srcnick, $text );
146              
147 0 0         if( my $target = $self->pick_display_target( $event->{display} ) ) {
148 0           $target->push_displayevent( "irc.$eventname", { target => $self->name, nick => $srcnick, text => $event->{text} } );
149 0 0         $target->bump_level( $event->{level} ) if defined $event->{level};
150              
151 0           $target->reify;
152             }
153              
154 0           return 1;
155             }
156              
157             sub on_message_ctcp_ACTION
158             {
159 0     0 0   my $self = shift;
160 0           my ( $message, $hints ) = @_;
161              
162 0           my $srcnick = $hints->{prefix_name};
163 0           my $text = $hints->{ctcp_args};
164              
165 0           my $net = $self->{net};
166              
167 0           my $event = {
168             %$hints,
169             text => $net->format_text_tagged( $text ),
170             is_action => 1,
171             level => $self->default_message_level( $hints ),
172             display => "self",
173             };
174              
175 0           $net->run_rulechain( "input", $event );
176              
177 0           $self->fire_event( "act", $srcnick, $text );
178              
179 0 0         if( my $target = $self->pick_display_target( $event->{display} ) ) {
180 0           $target->push_displayevent( "irc.act", { target => $self->name, nick => $srcnick, text => $event->{text} } );
181 0 0         $target->bump_level( $event->{level} ) if defined $event->{level};
182              
183 0           $target->reify;
184             }
185              
186 0           return 1;
187             }
188              
189             sub on_connected
190             {
191 0     0 0   my $self = shift;
192              
193 0           $self->push_displayevent( "status", { text => "Server is connected" } );
194             }
195              
196             sub on_disconnected
197             {
198 0     0 0   my $self = shift;
199 0           my ( $message ) = @_;
200              
201 0           $self->push_displayevent( "status", { text => $message } );
202             }
203              
204             sub _split_text_chunks
205             {
206 0     0     my ( $text, $maxlen, $on_chunk ) = @_;
207              
208 0           my $head = "<< ";
209 0           my $tail = " >>";
210              
211 0           while( length $text ) {
212 0 0         if( $maxlen >= length $text ) {
213 0           $on_chunk->( $text );
214 0           return;
215             }
216              
217 0           my $prefix = substr $text, 0, $maxlen - length( $tail );
218 0 0         if( $prefix =~ m/\s+\S+$/ ) {
219 0           substr( $prefix, $-[0] ) = "";
220             }
221              
222 0           $on_chunk->( $prefix . $tail );
223              
224 0           substr( $text, 0, length $prefix ) = "";
225 0           $text =~ s/^\s+//;
226 0           substr( $text, 0, 0 ) = $head;
227             }
228             }
229              
230             sub msg
231             {
232 0     0 0   my $self = shift;
233 0           my ( $text, %hints ) = @_;
234              
235 0           my $irc = $self->{irc};
236 0           my $net = $self->{net};
237              
238             my $event = {
239             text => Circle::TaggedString->new( $text ),
240             is_action => $hints{action},
241 0           };
242              
243 0           $net->run_rulechain( "output", $event );
244              
245 0           my $is_action = $event->{is_action};
246              
247             my $maxlen = 510 -
248             # To work out the maximum message length size we'd need to know our own
249             # prefix that the server will send. We can't know the host, but we know
250             # everything else. Just pretend it's maximal length, 64
251 0           ( length( $irc->{nick} ) + length( $irc->{user} ) + 64 + PREFIX_OVERHEAD );
252 0           my $target = $self->name;
253              
254 0           foreach my $line ( split m/\n/, $event->{text}->str ) {
255 0 0         if( $is_action ) {
256             _split_text_chunks( $line, $maxlen - length($target) - CTCP_ACTION_OVERHEAD, sub {
257 0     0     $irc->send_ctcp( undef, $target, "ACTION", $_[0] );
258 0           });
259             }
260             else {
261             _split_text_chunks( $line, $maxlen - length($target) - PRIVMSG_OVERHEAD, sub {
262 0     0     $irc->send_message( "PRIVMSG", undef, $target, $_[0] );
263 0           });
264             }
265              
266 0           my $line_formatted = $net->format_text( $line );
267              
268 0 0         $self->fire_event( $is_action ? "act" : "msg", $irc->nick, $line );
269 0 0         $self->push_displayevent( $is_action ? "irc.act" : "irc.msg", { target => $self->name, nick => $irc->nick, text => $line_formatted } );
270             }
271             }
272              
273             sub method_msg
274             {
275 0     0 0   my $self = shift; my $ctx = shift;
  0            
276 0           $self->msg( $_[0], action => 0 );
277             }
278              
279             sub notice
280             {
281 0     0 0   my $self = shift;
282 0           my ( $text ) = @_;
283              
284 0           my $irc = $self->{irc};
285 0           $irc->send_message( "NOTICE", undef, $self->name, $text );
286              
287 0           my $net = $self->{net};
288 0           my $text_formatted = $net->format_text( $text );
289              
290 0           $self->fire_event( "notice", $irc->nick, $text );
291 0           $self->push_displayevent( "irc.notice", { target => $self->name, nick => $irc->nick, text => $text_formatted } );
292             }
293              
294             sub method_notice
295             {
296 0     0 0   my $self = shift; my $ctx = shift;
  0            
297 0           $self->notice( @_ );
298             }
299              
300             sub method_act
301             {
302 0     0 0   my $self = shift; my $ctx = shift;
  0            
303 0           $self->msg( $_[0], action => 1 );
304             }
305              
306             sub command_say
307             : Command_description("Quote text directly as a PRIVMSG")
308             : Command_arg('text', eatall => 1)
309             {
310 0     0 0 0 my $self = shift;
311 0         0 my ( $text ) = @_;
312              
313 0         0 $self->msg( $text, action => 0 );
314              
315 0         0 return;
316 4     4   22 }
  4         9  
  4         29  
317              
318             sub command_me
319             : Command_description("Send a CTCP ACTION")
320             : Command_arg('text', eatall => 1)
321             {
322 0     0 0   my $self = shift;
323 0           my ( $text ) = @_;
324              
325 0           $self->msg( $text, action => 1 );
326              
327 0           return;
328 4     4   759 }
  4         6  
  4         16  
329              
330             sub commandable_parent
331             {
332 0     0 0   my $self = shift;
333 0           return $self->{net};
334             }
335              
336             sub enumerable_name
337             {
338 0     0 0   my $self = shift;
339 0           return $self->get_prop_tag;
340             }
341              
342             sub parent
343             {
344 0     0 0   my $self = shift;
345 0           return $self->{net};
346             }
347              
348             sub enter_text
349             {
350 0     0 0   my $self = shift;
351 0           my ( $text ) = @_;
352              
353 0 0         return unless length $text;
354              
355 0           $self->msg( $text );
356             }
357              
358             sub get_widget_commandentry
359             {
360 0     0 0   my $self = shift;
361 0           my $widget = $self->SUPER::get_widget_commandentry;
362              
363 0           $self->{net}->add_entry_widget_completegroups( $widget );
364              
365 0           return $widget;
366             }
367              
368             0x55AA;