File Coverage

blib/lib/AnyEvent/IRC/Server.pm
Criterion Covered Total %
statement 187 283 66.0
branch 24 58 41.3
condition 6 19 31.5
subroutine 34 50 68.0
pod 1 13 7.6
total 252 423 59.5


line stmt bran cond sub pod time code
1             package AnyEvent::IRC::Server;
2              
3 6     6   1899416 use strict;
  6         17  
  6         264  
4 6     6   35 use warnings;
  6         13  
  6         466  
5             our $VERSION = '0.03';
6 6     6   34 use base qw/Object::Event/;
  6         18  
  6         1634  
7 6     6   35733 use AnyEvent::Handle;
  6         9138  
  6         192  
8 6     6   1198 use AnyEvent::Socket;
  6         18995  
  6         888  
9 6     6   1228 use AnyEvent::IRC::Util qw/parse_irc_msg/;
  6         18407  
  6         352  
10 6     6   6065 use Sys::Hostname;
  6         8488  
  6         384  
11 6     6   1164 use POSIX;
  6         7593  
  6         60  
12 6     6   31006 use Scalar::Util qw/refaddr/;
  6         16  
  6         1193  
13              
14             use Class::Accessor::Lite (
15 6         56 rw => [
16             qw(host port handles servername channels topics spoofed_nick prepared_cb nick2handle)
17             ],
18 6     6   10108 );
  6         7504  
19              
20             my $CRLF = "\015\012";
21              
22             BEGIN {
23 6     6   892 no strict 'refs';
  6         12  
  6         443  
24 6     6   67 while (my ($code, $name) = each %AnyEvent::IRC::Util::RFC_NUMCODE_MAP) {
25 846         4598 *{"${name}"} = sub () { $code };
  846         28587  
  0         0  
26             }
27             };
28              
29             sub debugf {
30 109 50   109 0 259 return unless $ENV{AEIS_DEBUG};
31 0         0 require Data::Dumper;
32 0         0 require Term::ANSIColor;
33 0         0 local $Data::Dumper::Terse=1;
34 0         0 local $Data::Dumper::Indent=0;
35 0         0 my $fmt = shift;
36 0 0       0 my $s = sprintf $fmt, (map {
    0          
37 0         0 ref($_) ? (
38             Data::Dumper::Dumper($_)
39             ) : (defined($_) ? $_ : '<>')
40             } @_);
41 0         0 my ($package, $filename, $line) = caller(0);
42 0         0 $s .= " at $filename line $line\n";
43 0         0 print Term::ANSIColor::colored(["cyan"], $s);
44             }
45              
46             sub new {
47 2     2 1 13933 my $class = shift;
48             my $self = $class->SUPER::new(
49             handles => {}, # refaddr($handle) => $handle
50             channels => {},
51             topics => {},
52             spoofed_nick => {},
53             nick2handle => {}, # $nick => $hanldle,
54             welcome => 'Welcome to the my IRC server',
55             servername => hostname(),
56             network => 'AnyEventIRCServer',
57             ctime => POSIX::strftime( '%Y-%m-%d %H:%M:%S', localtime() ),
58             channel_chars => '#&',
59             prepared_cb => sub {
60 0     0   0 my ($self, $host, $port) = @_;
61 0         0 print "$class is ready on : $host:$port\n";
62             },
63 2         17 @_,
64             );
65              
66            
67             my $say = sub {
68 33     33   122 my ($handle, $cmd, @args) = @_;
69 33         90 my $msg = mk_msg_ex($self->host, $cmd, $handle->{nick}, @args);
70 33         68 debugf("Sending '%s'", $msg);
71 33         38 $msg .= $CRLF;
72 33         88 $handle->push_write($msg)
73 2         8339 };
74             my $need_more_params = sub {
75 0     0   0 my ($handle, $cmd) = @_;
76 0         0 $say->($handle, ERR_NEEDMOREPARAMS, $cmd, 'Not enough parameters');
77 2         12 };
78             $self->reg_cb(
79             nick => sub {
80 3     3   50 my ($self, $msg, $handle) = @_;
81 3         4 my ($nick) = @{$msg->{params}};
  3         8  
82 3 50       15 unless (defined $nick) {
83 0         0 return $need_more_params->($handle, 'NICK');
84             }
85 3 50       12 if ($self->nick2handle->{$nick}) {
86 0         0 return $say->($handle, ERR_NICKNAMEINUSE, $nick, 'Nickname already in use');
87             }
88 3         21 debugf("Set nick: %s", $nick);
89 3         5 $handle->{nick} = $nick;
90 3         8 $self->nick2handle->{$nick} = $handle;
91             # TODO: broadcast to each user
92             },
93             user => sub {
94 3     3   47 my ($self, $msg, $handle) = @_;
95 3         4 my ($user, $host, $server, $realname) = @{$msg->{params}};
  3         11  
96             # TODO: Note that hostname and servername are normally ignored by the IRC server when the USER command comes from a directly connected client (for security reasons)
97 3         8 $handle->{user} = $user;
98 3         18 $handle->{hostname} = $host;
99 3         6 $handle->{servername} = $server;
100 3         7 $handle->{realname} = $realname;
101              
102 3         11 $say->( $handle, RPL_WELCOME(), $self->{welcome} );
103 3         201 $say->( $handle, RPL_YOURHOST(), "Your host is @{[ $self->servername ]} [@{[ $self->servername ]}/@{[ $self->port ]}]. @{[ ref $self ]}/$VERSION" ); # 002
  3         14  
  3         27  
  3         24  
  3         28  
104 3         202 $say->( $handle, RPL_CREATED(), "This server was created $self->{ctime}");
105 3         153 $say->( $handle, RPL_MYINFO(), "@{[ $self->servername ]} @{[ ref $self ]}-$VERSION" ); # 004
  3         9  
  3         36  
106 3         145 $say->( $handle, ERR_NOMOTD(), "MOTD File is missing" );
107             },
108             'join' => sub {
109 5     5   75 my ($self, $msg, $handle) = @_;
110 5         7 my ($chans) = @{$msg->{params}};
  5         10  
111 5 50       16 unless ($chans) {
112 0         0 return $need_more_params->($handle, 'JOIN');
113             }
114 5         17 for my $chan ( split /,/, $chans ) {
115 5         10 my $nick = $handle->{nick};
116 5         10 debugf("%s joined to %s", $nick, $chans);
117 5         16 $self->channels->{$chan}->{handles}->{$nick} = $handle;
118              
119             # server reply
120 5   50     46 $say->( $handle, RPL_TOPIC(), $chan, $self->topics->{$chan} || '' );
121 5         239 for my $handle (values %{$self->channels->{$chan}->{handles}}) {
  5         15  
122 6 50       74 next unless $handle->{nick};
123 6 50       17 next if $self->spoofed_nick->{$handle->{nick}};
124 6         41 $say->( $handle, RPL_NAMREPLY(), $chan, $handle->{nick} );
125             }
126 5         209 $say->( $handle, RPL_ENDOFNAMES(), $chan, 'End of NAMES list.' );
127              
128             # send join message
129 5         182 my $comment = sprintf '%s!%s@%s', $nick, $nick, $self->servername;
130             # my $comment = sprintf '%s!%s@%s', $nick, $handle->{user}, $handle->{servername};
131 5         46 my $raw = mk_msg_ex($comment, 'JOIN', $chan) . $CRLF;
132 5         9 for my $handle (values %{$self->channels->{$chan}->{handles}}) {
  5         15  
133 6 50       68 next unless $handle->{nick};
134 6 50       14 next if $self->spoofed_nick->{$handle->{nick}};
135 6         51 $handle->push_write($raw);
136             }
137 5         187 $self->event('daemon_join' => $nick, $chan);
138             }
139             },
140             part => sub {
141 0     0   0 my ($self, $msg, $handle) = @_;
142 0         0 my ($chans, $text) = @{$msg->{params}};
  0         0  
143 0 0       0 unless ($chans) {
144 0         0 return $need_more_params->($handle, 'PART');
145             }
146 0         0 for my $chan ( split /,/, $chans ) {
147 0         0 my $nick = $handle->{nick};
148 0         0 $self->_intern_part($nick, $chan, $text);
149 0         0 $self->event('daemon_part' => $nick, $chan);
150             }
151             },
152             topic => sub {
153 2     2   33 my ($irc, $msg, $handle) = @_;
154 2         2 my ($chan, $topic) = @{$msg->{params}};
  2         6  
155 2 50       5 unless ($chan) {
156 0         0 return $need_more_params->($handle, 'TOPIC');
157             }
158 2 50       4 if ($topic) {
159 2         7 $say->( $handle, RPL_TOPIC, $self->topics->{$chan} );
160 2         74 my $nick = $handle->{nick};
161 2         7 $self->_intern_topic($nick, $chan, $topic);
162 2         7 $self->event('daemon_topic' => $nick, $chan, $topic);
163             } else {
164 0         0 $say->( $handle, RPL_NOTOPIC, $chan, 'No topic is set' );
165             }
166             },
167             'privmsg' => sub {
168 1     1   18 my ($irc, $msg, $handle) = @_;
169 1         2 my ($chan, $text) = @{$msg->{params}};
  1         4  
170 1 50       4 unless ($chan) {
171 0         0 return $need_more_params->($handle, 'PRIVMSG');
172             }
173 1         5 my $nick = $handle->{nick};
174 1 50       5 if ($nick eq '*') {
175 0         0 warn 'Nick was not set.';
176             }
177 1         5 $self->_intern_privmsg($nick, $chan, $text);
178 1         5 $self->event('daemon_privmsg' => $nick, $chan, $text);
179             },
180             'notice' => sub {
181 0     0   0 my ($irc, $raw, $handle) = @_;
182 0         0 my ($chan, $msg) = @{$raw->{params}};
  0         0  
183 0 0       0 unless ($msg) {
184 0         0 return $need_more_params->($handle, 'NOTICE');
185             }
186 0         0 my $nick = $handle->{nick};
187 0         0 $self->_intern_notice($nick, $chan, $msg);
188 0         0 $self->event('daemon_notice' => $nick, $chan, $msg);
189             },
190             'list' => sub {
191 1     1   16 my ($irc, $raw, $handle) = @_;
192 1         2 my ($chans, $msg) = @{$raw->{params}};
  1         3  
193 1         5 $self->_intern_list($handle, $chans);
194             },
195             who => sub {
196 0     0   0 my ($irc, $msg, $handle) = @_;
197 0         0 my ($name) = @{$msg->{params}};
  0         0  
198              
199 0 0       0 unless ( $self->channels->{$name} ) {
200             # TODO: ZNC calls '*'.
201             # AEIS should process it.
202 0         0 debugf("The channel is not listed: $name");
203 0         0 $say->( $handle, RPL_ENDOFWHO(), 'END of /WHO list');
204 0         0 return;
205             # return $need_more_params->($handle, 'WHO'); # TODO
206             }
207              
208 0         0 $say->( $handle, RPL_WHOREPLY(), $name, $handle->{user}, $handle->{hostname}, $handle->{servername}, $handle->{nick},"H:1", $handle->{realname});
209 0         0 $say->( $handle, RPL_ENDOFWHO(), 'END of /WHO list');
210             },
211             ping => sub {
212 0     0   0 my ($irc, $msg, $handle) = @_;
213 0         0 $say->( $handle, 'PONG', $msg->{params}->[0]);
214             },
215 2         79 );
216 2         1230 return $self;
217             }
218              
219             sub _server_comment {
220 1     1   2 my ($self, $nick) = @_;
221 1         4 return sprintf '%s!~%s@%s', $nick, $nick, $self->servername;
222             }
223              
224             sub _send_chan_msg {
225 4     4   20 my ($self, $nick, $chan, @args) = @_;
226             # send join message
227 4         11 my $handle = $self->channels->{$chan}->{handles}->{$nick};
228 4   66     47 my $comment = sprintf '%s!%s@%s', $nick, $handle->{user} || $nick, $handle->{servername} || $self->servername;
      33        
229 4         36 my $raw = mk_msg_ex($comment, @args);
230 4         10 debugf("_send_chan_msg: %s", $raw);
231 4         6 $raw .= $CRLF;
232 4 50       13 if ($self->is_channel_name($chan)) {
233 4         6 for my $handle (values %{$self->channels->{$chan}->{handles}}) {
  4         11  
234 6 50       108 next unless $handle->{nick};
235 6 100       24 next if $handle->{nick} eq $nick;
236 3 50       6 next if $self->spoofed_nick->{$handle->{nick}};
237 3         21 $handle->push_write($raw);
238             }
239             } else {
240             # private talk
241             # TODO: TOO SLOW
242 0         0 my $handle = $self->nick2handle->{$chan};
243 0 0       0 if ($handle) {
244 0         0 $handle->push_write($raw);
245             }
246             }
247             }
248              
249             sub run {
250 2     2 0 80 my $self = shift;
251             tcp_server $self->{host}, $self->{port}, sub {
252 3     3   19808 my ($fh, $host, $port) = @_;
253             my $handle = AnyEvent::Handle->new(
254             on_error => sub {
255 0         0 my ($handle) = @_;
256 0         0 $self->event('on_error' => $handle);
257             },
258             on_eof => sub {
259 0         0 my ($handle) = @_;
260 0         0 $self->event('on_eof' => $handle);
261             # TODO: part from each channel
262 0 0       0 if (my $nick = $handle->{nick}) {
263 0         0 delete $self->nick2handle->{$nick};
264             }
265 0         0 delete $self->handles->{refaddr($handle)};
266             },
267 3         38 fh => $fh,
268             );
269 3         170 $handle->{nick} = '*';
270             $handle->on_read(sub {
271             $handle->push_read(line => sub {
272 17         615 my ($handle, $line, $eol) = @_;
273 17         57 my $msg = parse_irc_msg($line);
274 17         534 $self->handle_msg($msg, $handle);
275 17         9726 });
276 3         25 });
277 3         111 $self->handles->{refaddr($handle)} = $handle;
278 2         29 }, $self->prepared_cb();
279             }
280              
281             sub handle_msg {
282 17     17 0 28 my ($self, $msg, $handle) = @_;
283 17         33 my $event = lc($msg->{command});
284 17         34 $event =~ s/^(\d+)$/irc_$1/g;
285 17         85 debugf("%s %s", $event, $msg);
286 17         55 $self->event($event, $msg, $handle);
287             }
288              
289             # -------------------------------------------------------------------------
290              
291             sub add_spoofed_nick {
292 0     0 0 0 my ($self, $nick) = @_;
293 0         0 $self->{spoofed_nick}->{$nick} = 1;
294             }
295              
296              
297             # -------------------------------------------------------------------------
298              
299             sub daemon_cmd_join {
300 0     0 0 0 my ($self, $nick, $chan, $msg) = @_;
301 0 0       0 return if $self->channels->{$chan}->{handles}->{$nick};
302 0         0 $self->add_spoofed_nick($nick);
303 0         0 $self->_intern_join($nick, $chan, $self->nick2handle->{$nick});
304             }
305              
306             sub daemon_cmd_kick {
307 0     0 0 0 my ($self, $kicker, $chan, $kickee, $comment) = @_;
308 0         0 $self->_intern_kick($kicker, $chan, $kickee, $comment);
309             }
310              
311             sub daemon_cmd_topic {
312 0     0 0 0 my ($self, $nick, $chan, $topic) = @_;
313 0         0 $self->_intern_topic($nick, $chan, $topic);
314             }
315              
316             sub daemon_cmd_part {
317 0     0 0 0 my ($self, $nick, $chan, $msg) = @_;
318 0         0 $self->_intern_part($nick, $chan, $msg);
319             }
320              
321             sub daemon_cmd_privmsg {
322 1     1 0 1224 my ($self, $nick, $chan, $msg) = @_;
323 1         5 $self->_intern_privmsg($nick, $chan, $msg);
324             }
325              
326             sub daemon_cmd_notice {
327 0     0 0 0 my ($self, $nick, $chan, $msg) = @_;
328 0         0 debugf('%s', [$nick, $chan, $msg]);
329 0         0 $self->_intern_notice($nick, $chan, $msg);
330             }
331              
332             # -------------------------------------------------------------------------
333              
334             sub _intern_list {
335 1     1   2 my ($self, $handle, $chans) = @_;
336              
337 1         2 my $nick = $handle->{nick};
338 1         4 my $comment = $self->_server_comment($nick);
339             my $send = sub {
340 5     5   43 my $raw = mk_msg_ex($comment, @_) . $CRLF;
341 5         16 $handle->push_write($raw);
342 1         11 };
343             my $send_rpl_list = sub {
344 3     3   5 my $chan = shift;
345 3   100     4 $send->(RPL_LIST, $nick, $chan, scalar keys %{$self->channels->{$chan}->{handles}}, ':'.($self->topics->{$chan} || ''));
  3         8  
346 1         6 };
347 1         4 $send->(RPL_LISTSTART, $nick, 'Channel', ':Users', 'Name');
348 1 50       39 if ($chans) {
349 0         0 for my $chan (split /,/, $chans) {
350 0 0       0 if ($self->channels->{$chan}) {
351 0         0 $send_rpl_list->($chan);
352             }
353             }
354             } else {
355 1         4 my $channels = $self->channels;
356 1         11 while (my ($chan, $val) = each %$channels) {
357 3         71 $send_rpl_list->($chan);
358             }
359             }
360 1         35 $send->(RPL_LISTEND, $nick, 'End of /LIST');
361             }
362              
363             sub _intern_privmsg {
364 2     2   6 my ($self, $nick, $chan, $text) = @_;
365 2         7 $self->_send_chan_msg($nick, $chan, 'PRIVMSG', $chan, $text);
366             }
367              
368             sub _intern_notice {
369 0     0   0 my ($self, $nick, $chan, $text) = @_;
370 0         0 debugf('%s', [$nick, $chan, $text]);
371 0         0 $self->_send_chan_msg($nick, $chan, 'NOTICE', $chan, $text);
372             }
373              
374             sub _intern_topic {
375 2     2   5 my ($self, $nick, $chan, $topic) = @_;
376 2         6 $self->topics->{$chan} = $topic;
377 2         14 $self->_send_chan_msg($nick, $chan, 'TOPIC', $chan, $self->topics->{$chan});
378             }
379              
380             sub _intern_join {
381 0     0   0 my ($self, $nick, $chan, $handle) = @_;
382 0         0 $self->channels->{$chan}->{handles}->{$nick} = $handle;
383 0         0 $self->_send_chan_msg($nick, $chan, 'JOIN', $chan);
384             }
385              
386             sub _intern_part {
387 0     0   0 my ($self, $nick, $chan, $msg) = @_;
388 0   0     0 $msg ||= $nick;
389              
390             # send part message
391 0         0 $self->_send_chan_msg($nick, $chan, 'PART', $chan, $msg);
392 0         0 delete $self->channels->{$chan}->{handles}->{$nick};
393             }
394              
395             # /KICK []
396             # use this line in /kick: $self->event('daemon_kick' => $kicker, $chan, $kickee, $comment);
397             sub _intern_kick {
398 0     0   0 my ($self, $kicker, $chan, $kickee, $comment) = @_;
399              
400             # TODO: implement
401             # TODO: oper check
402 0         0 my $handle = $self->channels->{$chan}->{handles}->{$kicker};
403 0   0     0 my $cmt_irc = sprintf '%s!%s@%s', $kicker, $handle->{user} || $kicker , $handle->{servername} || $self->servername;
      0        
404 0         0 my $raw = mk_msg_ex($cmt_irc, 'KICK', $chan, $kickee, $comment) . $CRLF;
405 0         0 for my $handle (values %{$self->channels->{$chan}->{handles}}) {
  0         0  
406 0         0 $handle->push_write($raw);
407             }
408 0         0 delete $self->channels->{$chan}->{handles}->{$kickee};
409             }
410              
411             # -------------------------------------------------------------------------
412              
413             sub is_channel_name {
414 4     4 0 7 my ( $self, $string ) = @_;
415 4         10 my $cchrs = $self->{channel_chars};
416 4         81 $string =~ /^([\Q$cchrs\E]+)(.+)$/;
417             }
418              
419             sub mk_msg_ex {
420 47     47 0 244 my ( $prefix, $command, @params ) = @_;
421 47         55 my $msg = "";
422              
423 47 100       113 $msg .= defined $prefix ? ":$prefix " : "";
424 47         73 $msg .= "$command";
425              
426 47         42 my $trail;
427 47         89 debugf("%s", \@params);
428 47 100       106 if ( @params >= 2 ) {
429 42         51 $trail = pop @params;
430             }
431              
432             # FIXME: params must be counted, and if > 13 they have to be
433             # concationated with $trail
434 47         61 map { $msg .= " $_" } @params;
  71         145  
435              
436 47 100       108 $msg .= defined $trail ? " :$trail" : "";
437              
438 47         107 return $msg;
439             }
440              
441             1;
442             __END__