source: perl/modules/IRC/lib/BarnOwl/Module/IRC/Connection.pm @ 09bd74c

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