source: perl/modules/IRC/lib/BarnOwl/Module/IRC/Connection.pm @ 13ee8f2

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