/usr/share/perl5/App/Alice/Test/MockIRC.pm is in alice 0.19-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 | package App::Alice::Test::MockIRC;
use Any::Moose;
use AnyEvent::IRC::Util qw/parse_irc_msg prefix_nick mk_msg/;
use Try::Tiny;
has cbs => (is => 'rw', default => sub {{}});
has nick => (is => 'rw');
has user_prefix => (
is => 'rw',
lazy => 1,
default => sub{$_[0]->nick."!".$_[0]->nick."\@host"}
);
has events => (
is => 'rw',
default => sub {
my $self = shift;
{
TOPIC => sub {
my $msg = shift;
my $nick = prefix_nick($msg->{prefix});
$self->cbs->{channel_topic}->($self, @{$msg->{params}}, $nick);
},
JOIN => sub {
my $msg = shift;
my $nick = prefix_nick($msg->{prefix});
$self->cbs->{join}->($self, $nick, $msg->{params}[0], $nick eq $self->nick);
$self->cbs->{channel_add}->($self, $msg, $msg->{params}[0], $nick);
$self->send_srv(WHO => $msg->{params}[0]);
},
NICK => sub {
my $msg = shift;
my $nick = prefix_nick($msg->{prefix});
$self->cbs->{nick_change}->($self, $nick, ${$msg->{params}}[0], $nick eq $self->nick);
},
PART => sub {
my $msg = shift;
my $nick = prefix_nick($msg->{prefix});
$self->cbs->{part}->($self, $nick, $msg->{params}[0], $nick eq $self->nick);
$self->cbs->{channel_remove}->($self, $msg, $msg->{params}[0], $nick);
},
PRIVMSG => sub {
my $msg = shift;
my $nick = prefix_nick($msg->{prefix});
$self->cbs->{privatemsg}->($self, $nick, $msg);
},
numeric => sub {
my ($msg, $number) = @_;
$self->cbs->{"irc_$number"}->($self, $msg);
},
}
}
);
sub send_srv {
my ($self, $command, @args) = @_;
my $echo = sub {mk_msg($self->user_prefix, $command, @args)};
my $map = {
map({$_ => $echo} qw/TOPIC JOIN PART NICK/),
WHO => sub{
my $user = ($args[0] =~ /^#/ ? "test" : $args[0]);
":local.irc 352 ".$self->nick." #test $user il.comcast.net local.irc $user H :0 $user";
},
};
$map->{$command} ? $self->send_cl($map->{$command}->())
: warn "no line mapped for $command\n"
}
sub send_raw {
my ($self, $line) = @_;
$self->send_srv(split ' ', $line);
}
sub send_cl {
my ($self, $line) = @_;
my $msg = parse_irc_msg($line);
my $cmd = ($msg->{command} =~ /^\d+/ ? 'numeric' : $msg->{command});
try { $self->events->{$cmd}->($msg, $msg->{command}) if $self->events->{$cmd} }
catch { warn "$_\n" };
}
sub enable_ssl {}
sub isupport {}
sub ctcp_auto_reply {}
sub connect {
my $self = shift;
$self->cbs->{connect}->();
}
sub register {
my $self = shift;
$self->cbs->{registered}->();
}
sub disconnect {
my $self = shift;
$self->cbs->{disconnect}->();
}
sub enable_ping {}
sub reg_cb {
my ($self, %callbacks) = @_;
for (keys %callbacks) {
$self->cbs->{$_} = $callbacks{$_};
}
}
__PACKAGE__->meta->make_immutable;
1;
|