source: perl/modules/IRC/lib/BarnOwl/Module/IRC/Connection.pm @ 0b0e460

release-1.8release-1.9
Last change on this file since 0b0e460 was 0b0e460, checked in by Nelson Elhage <nelhage@mit.edu>, 11 years ago
Squelch an "uninitialized" warning. I have no idea why ->{command} should be undef, but empirically it sometimes is.
  • Property mode set to 100644
File size: 14.3 KB
Line 
1use strict;
2use warnings;
3
4package BarnOwl::Module::IRC::Connection;
5use BarnOwl::Timer;
6
7=head1 NAME
8
9BarnOwl::Module::IRC::Connection
10
11=head1 DESCRIPTION
12
13This module is a wrapper around Net::IRC::Connection for BarnOwl's IRC
14support
15
16=cut
17
18use AnyEvent::IRC::Client;
19use AnyEvent::IRC::Util qw(split_prefix prefix_nick encode_ctcp);
20
21use base qw(Class::Accessor);
22use Exporter 'import';
23__PACKAGE__->mk_accessors(qw(conn alias motd names_tmp whois_tmp server autoconnect_channels));
24our @EXPORT_OK = qw(is_private);
25
26use BarnOwl;
27use Scalar::Util qw(weaken);
28
29sub new {
30    my $class = shift;
31    my $alias = shift;
32    my $host  = shift;
33    my $port  = shift;
34    my $args  = shift;
35    my $nick = $args->{nick};
36    my $conn = AnyEvent::IRC::Client->new();
37    my $self = bless({}, $class);
38    $self->conn($conn);
39    $self->autoconnect_channels([]);
40    $self->alias($alias);
41    $self->server($host);
42    $self->motd("");
43    $self->names_tmp(0);
44    $self->whois_tmp("");
45
46    if(delete $args->{SSL}) {
47        $conn->enable_ssl;
48    }
49    $conn->connect($host, $port, $args);
50    $conn->{heap}{parent} = $self;
51    weaken($conn->{heap}{parent});
52
53    sub on {
54        my $meth = "on_" . shift;
55        return sub {
56            my $conn = shift;
57            return unless $conn->{heap}{parent};
58            $conn->{heap}{parent}->$meth(@_);
59        }
60    }
61
62    # $self->conn->add_default_handler(sub { shift; $self->on_event(@_) });
63    $self->conn->reg_cb(registered => on("connect"),
64                        connfail   => sub { BarnOwl::error("Connection to $host failed!") },
65                        disconnect => on("disconnect"),
66                        publicmsg  => on("msg"),
67                        privatemsg => on("msg"));
68    for my $m (qw(welcome yourhost created
69                  luserclient luserop luserchannels luserme
70                  error)) {
71        $self->conn->reg_cb("irc_$m" => on("admin_msg"));
72    }
73    $self->conn->reg_cb(irc_375       => on("motdstart"),
74                        irc_372       => on("motd"),
75                        irc_376       => on("endofmotd"),
76                        irc_join      => on("join"),
77                        irc_part      => on("part"),
78                        irc_quit      => on("quit"),
79                        irc_433       => on("nickinuse"),
80                        channel_topic => on("topic"),
81                        irc_333       => on("topicinfo"),
82                        irc_353       => on("namreply"),
83                        irc_366       => on("endofnames"),
84                        irc_311       => on("whois"),
85                        irc_312       => on("whois"),
86                        irc_319       => on("whois"),
87                        irc_320       => on("whois"),
88                        irc_318       => on("endofwhois"),
89                        irc_mode      => on("mode"),
90                        irc_401       => on("nosuch"),
91                        irc_402       => on("nosuch"),
92                        irc_403       => on("nosuch"),
93                        nick_change   => on("nick"),
94                        ctcp_action   => on("ctcp_action"),
95                        'irc_*' => sub { BarnOwl::debug("IRC: " . $_[1]->{command}) });
96
97    return $self;
98}
99
100sub nick {
101    my $self = shift;
102    return $self->conn->nick;
103}
104
105sub getSocket
106{
107    my $self = shift;
108    return $self->conn->socket;
109}
110
111sub me {
112    my ($self, $to, $msg) = @_;
113    $self->conn->send_msg('privmsg', $to,
114                          encode_ctcp(['ACTION', $msg]))
115}
116
117################################################################################
118############################### IRC callbacks ##################################
119################################################################################
120
121sub new_message {
122    my $self = shift;
123    my $evt = shift;
124    my %args = (
125        type        => 'IRC',
126        server      => $self->server,
127        network     => $self->alias,
128        @_
129       );
130    if ($evt) {
131        my ($nick, $user, $host) = split_prefix($evt);
132        $args{sender}   ||= $nick;
133        $args{hostname} ||= $host if defined($host);
134        $args{from}     ||= $evt->{prefix};
135        $args{params}   ||= join(' ', @{$evt->{params}})
136    }
137    return BarnOwl::Message->new(%args);
138}
139
140sub on_msg {
141    my ($self, $recipient, $evt) = @_;
142    my $body = strip_irc_formatting($evt->{params}->[1]);
143    $self->handle_message($recipient, $evt, $body);
144}
145
146sub on_ctcp_action {
147    my ($self, $src, $target, $msg) = @_;
148    my $body = strip_irc_formatting($msg);
149    my $evt = {
150        params => [$src],
151        type   => 'privmsg',
152        prefix => $src
153       };
154    $self->handle_message($target, $evt, "* $body");
155}
156
157sub handle_message {
158    my ($self, $recipient, $evt, $body) = @_;
159    my $msg = $self->new_message($evt,
160        direction   => 'in',
161        recipient   => $recipient,
162        body        => $body,
163        ($evt->{command}||'') eq 'notice' ?
164          (notice     => 'true') : (),
165        is_private($recipient) ?
166          (private  => 'true') : (channel => $recipient),
167        replycmd    => BarnOwl::quote('irc-msg', '-a', $self->alias,
168           (is_private($recipient) ? prefix_nick($evt) : $recipient)),
169        replysendercmd => BarnOwl::quote('irc-msg', '-a', $self->alias, prefix_nick($evt)),
170       );
171
172    BarnOwl::queue_message($msg);
173}
174
175
176sub on_admin_msg {
177    my ($self, $evt) = @_;
178    return if BarnOwl::Module::IRC->skip_msg($evt->{command});
179    BarnOwl::admin_message("IRC",
180            BarnOwl::Style::boldify('IRC ' . $evt->{command} . ' message from '
181                . $self->alias) . "\n"
182            . strip_irc_formatting(join ' ', cdr($evt->{params})));
183}
184
185sub on_motdstart {
186    my ($self, $evt) = @_;
187    $self->motd(join "\n", cdr(@{$evt->{params}}));
188}
189
190sub on_motd {
191    my ($self, $evt) = @_;
192    $self->motd(join "\n", $self->motd, cdr(@{$evt->{params}}));
193}
194
195sub on_endofmotd {
196    my ($self, $evt) = @_;
197    $self->motd(join "\n", $self->motd, cdr(@{$evt->{params}}));
198    BarnOwl::admin_message("IRC",
199            BarnOwl::Style::boldify('MOTD for ' . $self->alias) . "\n"
200            . strip_irc_formatting($self->motd));
201}
202
203sub on_join {
204    my ($self, $evt) = @_;
205    my $chan = $evt->{params}[0];
206    my $msg = $self->new_message($evt,
207        loginout   => 'login',
208        action     => 'join',
209        channel    => $chan,
210        replycmd   => BarnOwl::quote('irc-msg', '-a', $self->alias, $chan),
211        replysendercmd => BarnOwl::quote('irc-msg', '-a', $self->alias, prefix_nick($evt)),
212        );
213    BarnOwl::queue_message($msg);
214}
215
216sub on_part {
217    my ($self, $evt) = @_;
218    my $chan = $evt->{params}[0];
219    my $msg = $self->new_message($evt,
220        loginout   => 'logout',
221        action     => 'part',
222        channel    => $chan,
223        replycmd   => BarnOwl::quote('irc-msg', '-a', $self->alias, $chan),
224        replysendercmd => BarnOwl::quote('irc-msg', '-a', $self->alias, prefix_nick($evt)),
225        );
226    BarnOwl::queue_message($msg);
227}
228
229sub on_quit {
230    my ($self, $evt) = @_;
231    my $msg = $self->new_message($evt,
232        loginout   => 'logout',
233        action     => 'quit',
234        from       => $evt->{prefix},
235        reason     => $evt->{params}->[0],
236        replycmd   => BarnOwl::quote('irc-msg', '-a', $self->alias, prefix_nick($evt)),
237        replysendercmd => BarnOwl::quote('irc-msg', '-a', $self->alias, prefix_nick($evt)),
238        );
239    BarnOwl::queue_message($msg);
240}
241
242sub disconnect {
243    my $self = shift;
244    delete $BarnOwl::Module::IRC::ircnets{$self->alias};
245    for my $k (keys %BarnOwl::Module::IRC::channels) {
246        my @conns = grep {$_ ne $self} @{$BarnOwl::Module::IRC::channels{$k}};
247        if(@conns) {
248            $BarnOwl::Module::IRC::channels{$k} = \@conns;
249        } else {
250            delete $BarnOwl::Module::IRC::channels{$k};
251        }
252    }
253    $self->motd("");
254}
255
256sub on_disconnect {
257    my ($self, $why) = @_;
258    $self->disconnect;
259    BarnOwl::admin_message('IRC',
260                           "[" . $self->alias . "] Disconnected from server");
261    if ($why && $why =~ m{error in connection}) {
262        $self->schedule_reconnect;
263    }
264}
265
266sub on_nickinuse {
267    my ($self, $evt) = @_;
268    BarnOwl::admin_message("IRC",
269                           "[" . $self->alias . "] " .
270                           $evt->{params}->[1] . ": Nick already in use");
271}
272
273sub on_nick {
274    my ($self, $old_nick, $new_nick, $is_me) = @_;
275    if ($is_me) {
276        BarnOwl::admin_message("IRC",
277                               "[" . $self->alias . "] " .
278                               "You are now known as $new_nick");
279    } else {
280        my $msg = $self->new_message('',
281            loginout   => 'login',
282            action     => 'nick change',
283            from       => $new_nick,
284            sender     => $new_nick,
285            replycmd   => BarnOwl::quote('irc-msg', '-a', $self->alias,
286                                         $new_nick),
287            replysendercmd => BarnOwl::quote('irc-msg', '-a', $self->alias,
288                                             $new_nick),
289            old_nick   => $old_nick);
290        BarnOwl::queue_message($msg);
291    }
292}
293
294sub on_topic {
295    my ($self, $channel, $topic, $who) = @_;
296    if ($channel) {
297        BarnOwl::admin_message("IRC",
298                "Topic for $channel on " . $self->alias . " is $topic");
299    } else {
300        BarnOwl::admin_message("IRC",
301                "Topic changed to $channel");
302    }
303}
304
305sub on_topicinfo {
306    my ($self, $evt) = @_;
307    my @args = @{$evt->{params}};
308    BarnOwl::admin_message("IRC",
309        "Topic for $args[1] set by $args[2] at " . localtime($args[3]));
310}
311
312# IRC gives us a bunch of namreply messages, followed by an endofnames.
313# We need to collect them from the namreply and wait for the endofnames message.
314# After this happens, the names_tmp variable is cleared.
315
316sub on_namreply {
317    my ($self, $evt) = @_;
318    return unless $self->names_tmp;
319    $self->names_tmp([@{$self->names_tmp}, split(' ', $evt->{params}[3])]);
320}
321
322sub cmp_user {
323    my ($lhs, $rhs) = @_;
324    my ($sigil_l) = ($lhs =~ m{^([+@]?)});
325    my ($sigil_r) = ($rhs =~ m{^([+@]?)});
326    my %rank = ('@' => 1, '+' => 2, '' => 3);
327    return ($rank{$sigil_l} <=> $rank{$sigil_r}) ||
328            $lhs cmp $rhs;
329}
330
331sub on_endofnames {
332    my ($self, $evt) = @_;
333    return unless $self->names_tmp;
334    my $names = BarnOwl::Style::boldify("Members of " . $evt->{params}->[1] . ":\n");
335    for my $name (sort {cmp_user($a, $b)} @{$self->names_tmp}) {
336        $names .= "  $name\n";
337    }
338    BarnOwl::popless_ztext($names);
339    $self->names_tmp(0);
340}
341
342sub on_whois {
343    my ($self, $evt) = @_;
344    my %names = (
345        311 => 'user',
346        312 => 'server',
347        319 => 'channels',
348        330 => 'whowas',
349       );
350    $self->whois_tmp(
351        $self->whois_tmp . "\n" . $names{$evt->{command}} . ":\n  " .
352        join("\n  ", cdr(cdr(@{$evt->{params}}))) . "\n"
353       );
354}
355
356sub on_endofwhois {
357    my ($self, $evt) = @_;
358    BarnOwl::popless_ztext(
359        BarnOwl::Style::boldify("/whois for " . $evt->{params}->[1] . ":\n") .
360        $self->whois_tmp
361    );
362    $self->whois_tmp('');
363}
364
365sub on_mode {
366    my ($self, $evt) = @_;
367    BarnOwl::admin_message("IRC",
368                           "[" . $self->alias . "] User " . (prefix_nick($evt)) . + " set mode " .
369                           join(" ", cdr(@{$evt->{params}})) . "on " . $evt->{params}->[0]
370                          );
371}
372
373sub on_nosuch {
374    my ($self, $evt) = @_;
375    my %things = (401 => 'nick', 402 => 'server', 403 => 'channel');
376    BarnOwl::admin_message("IRC",
377                           "[" . $self->alias . "] " .
378                           "No such @{[$things{$evt->{command}}]}: @{[$evt->{params}->[1]]}")
379}
380
381sub on_event {
382    my ($self, $evt) = @_;
383    return on_whois(@_) if ($evt->type =~ /^whois/);
384    BarnOwl::admin_message("IRC",
385            "[" . $self->alias . "] Unhandled IRC event of type " . $evt->type . ":\n"
386            . strip_irc_formatting(join("\n", $evt->args)))
387        if BarnOwl::getvar('irc:spew') eq 'on';
388}
389
390sub schedule_reconnect {
391    my $self = shift;
392    my $interval = shift || 5;
393
394    my $weak = $self;
395    weaken($weak);
396    if (defined $self->{reconnect_timer}) {
397        $self->{reconnect_timer}->stop;
398    }
399    $self->{reconnect_timer} = 
400        BarnOwl::Timer->new( {
401            name  => 'IRC (' . $self->alias . ') reconnect_timer',
402            after => $interval,
403            cb    => sub {
404                $weak->reconnect( $interval ) if $weak;
405            },
406        } );
407}
408
409sub cancel_reconnect {
410    my $self = shift;
411
412    if (defined $self->{reconnect_timer}) {
413        $self->{reconnect_timer}->stop;
414    }
415    delete $self->{reconnect_timer};
416}
417
418sub on_connect {
419    my $self = shift;
420    $self->connected("Connected to " . $self->alias . " as " . $self->nick)
421}
422
423sub connected {
424    my $self = shift;
425    my $msg = shift;
426    BarnOwl::admin_message("IRC", $msg);
427    $self->cancel_reconnect;
428    if ($self->autoconnect_channels) {
429        for my $c (@{$self->autoconnect_channels}) {
430            $self->conn->send_msg(join => $c);
431        }
432        $self->autoconnect_channels([]);
433    }
434    $self->conn->enable_ping(60, sub {
435                                 $self->disconnect("Connection timed out.");
436                                 $self->schedule_reconnect;
437                             });
438}
439
440sub reconnect {
441    my $self = shift;
442    my $backoff = shift;
443
444    $self->autoconnect_channels([keys(%{$self->channel_list})]);
445    $self->conn->connect;
446    if ($self->conn->connected) {
447        $self->connected("Reconnected to ".$self->alias);
448        return;
449    }
450
451    $backoff *= 2;
452    $backoff = 60*5 if $backoff > 60*5;
453    $self->schedule_reconnect( $backoff );
454}
455
456################################################################################
457########################### Utilities/Helpers ##################################
458################################################################################
459
460sub strip_irc_formatting {
461    my $body = shift;
462    # Strip mIRC colors. If someone wants to write code to convert
463    # these to zephyr colors, be my guest.
464    $body =~ s/\cC\d+(?:,\d+)?//g;
465    $body =~ s/\cO//g;
466   
467    my @pieces = split /\cB/, $body;
468    my $out = '';
469    while(@pieces) {
470        $out .= shift @pieces;
471        $out .= BarnOwl::Style::boldify(shift @pieces) if @pieces;
472    }
473    return $out;
474}
475
476# Determines if the given message recipient is a username, as opposed to
477# a channel that starts with # or &.
478sub is_private {
479    return shift !~ /^[\#\&]/;
480}
481
482sub cdr {
483    shift;
484    return @_;
485}
486
4871;
Note: See TracBrowser for help on using the repository browser.