| 1 |
#!perl |
| 2 |
use strict; |
| 3 |
no warnings; |
| 4 |
use Test::More; |
| 5 |
use AnyEvent::Impl::Perl; |
| 6 |
use AnyEvent; |
| 7 |
use Net::IRC3::Connection; |
| 8 |
use Net::IRC3::Client::Connection; |
| 9 |
use Net::IRC3::Util qw/split_prefix prefix_nick/; |
| 10 |
use Socket; |
| 11 |
use IO::Handle; |
| 12 |
$Net::IRC3::Client::Connection::DEBUG = 1; |
| 13 |
|
| 14 |
our $WATCHDOG; |
| 15 |
|
| 16 |
sub prepare_cl_srv { |
| 17 |
my $srv = Net::IRC3::Connection->new; |
| 18 |
my $cl = Net::IRC3::Client::Connection->new; |
| 19 |
|
| 20 |
socketpair (my $s1, my $s2, AF_UNIX, SOCK_STREAM, PF_UNSPEC) |
| 21 |
or die "socketpair: $!"; |
| 22 |
$s1 or die "couldn't make socketpair: $!"; |
| 23 |
$srv->use_socket ('localhost', '65533', $s1); |
| 24 |
$cl->use_socket ('localhost', '6667', $s2); |
| 25 |
|
| 26 |
($srv, $cl) |
| 27 |
} |
| 28 |
|
| 29 |
sub start_watchdog { |
| 30 |
my ($c, $checks) = @_; |
| 31 |
$WATCHDOG = |
| 32 |
AnyEvent->timer (after => 10, cb => sub { |
| 33 |
$c->broadcast; |
| 34 |
$checks->{watchdog} = 1; |
| 35 |
undef $WATCHDOG |
| 36 |
}); |
| 37 |
} |
| 38 |
|
| 39 |
sub uniq { |
| 40 |
my (@lst) = @_; |
| 41 |
my %h; |
| 42 |
$h{$_}++ for @lst; |
| 43 |
keys %h |
| 44 |
} |
| 45 |
|
| 46 |
plan tests => 20; |
| 47 |
|
| 48 |
{ |
| 49 |
my $c = AnyEvent->condvar; |
| 50 |
|
| 51 |
my ($srv, $cl) = prepare_cl_srv; |
| 52 |
my ($nick, $user, $real) = (test => testbot => "I'm a Net::IRC3 test"); |
| 53 |
my @test_nicks = qw/@elmex @testor foobar/; # for channel $test_chan1 |
| 54 |
my $test_chan1 = '#test'; |
| 55 |
my $test_chan2 = '#tESt2'; |
| 56 |
|
| 57 |
my $test_chan_msg_srcnick = 'testbot'; |
| 58 |
|
| 59 |
my $ss = {}; # server state |
| 60 |
my $checks = $cl->heap; # for storing testing check results |
| 61 |
$checks->{stage} = 0; |
| 62 |
|
| 63 |
$srv->reg_cb ( |
| 64 |
irc_nick => sub { |
| 65 |
my ($srv, $p) = @_; |
| 66 |
$ss->{nick} = $p->{params}->[0]; |
| 67 |
|
| 68 |
if ($ss->{retry} < 2) { |
| 69 |
if ($ss->{retry} > 0) { |
| 70 |
$cl->set_nick_change_cb (undef); |
| 71 |
} |
| 72 |
|
| 73 |
$ss->{retry}++; |
| 74 |
$srv->send_msg ( |
| 75 |
'localhost', '433' => |
| 76 |
"Nickname is already in use", $ss->{nick} |
| 77 |
); |
| 78 |
|
| 79 |
} elsif ($checks->{stage} == 0) { |
| 80 |
$checks->{srv_nick} = $ss->{nick}; |
| 81 |
|
| 82 |
$ss->{cl_prefix} = sprintf "%s!%s@%s", $ss->{nick}, $ss->{user}, 'localhost'; |
| 83 |
|
| 84 |
if ($ss->{user}) { |
| 85 |
$srv->send_msg ( |
| 86 |
'localhost', '001' => |
| 87 |
'Welcome to the Net::IRC3 test', $ss->{nick} |
| 88 |
); |
| 89 |
} |
| 90 |
} |
| 91 |
1 |
| 92 |
}, |
| 93 |
irc_user => sub { |
| 94 |
my ($srv, $p) = @_; |
| 95 |
$ss->{user} = $p->{params}->[0]; |
| 96 |
$ss->{real} = $p->{params}->[3]; |
| 97 |
|
| 98 |
$checks->{srv_user} = $ss->{user}; |
| 99 |
$checks->{srv_real} = $ss->{real}; |
| 100 |
$checks->{srv_nick} = $ss->{nick}; |
| 101 |
|
| 102 |
1 |
| 103 |
}, |
| 104 |
irc_pong => sub { |
| 105 |
my ($srv) = @_; |
| 106 |
$checks->{recv_pong} = 1; |
| 107 |
1 |
| 108 |
}, |
| 109 |
irc_privmsg => sub { |
| 110 |
my ($srv, $m) = @_; |
| 111 |
if ($m->{trailing} =~ /TEST HELLO/) { |
| 112 |
$srv->send_msg ( |
| 113 |
$test_chan_msg_srcnick |
| 114 |
. '!' |
| 115 |
. $test_chan_msg_srcnick |
| 116 |
. '@localhost', |
| 117 |
PRIVMSG => "TEST REPLY", $m->{params}->[0] |
| 118 |
); |
| 119 |
$checks->{recv_message} = $m->{trailing}; |
| 120 |
} |
| 121 |
}, |
| 122 |
irc_join => sub { |
| 123 |
my ($srv, $p) = @_; |
| 124 |
my $chan = $p->{params}->[0]; |
| 125 |
$srv->send_msg ($ss->{cl_prefix}, JOIN => $chan); |
| 126 |
|
| 127 |
if ($chan eq $test_chan1) { |
| 128 |
$srv->send_msg ( |
| 129 |
'localhost', '353', |
| 130 |
(join ' ', @test_nicks, $ss->{nick}), |
| 131 |
$ss->{nick}, '=', $chan |
| 132 |
); |
| 133 |
|
| 134 |
$srv->send_raw ("PING :fooobar"); |
| 135 |
|
| 136 |
$srv->send_msg ( |
| 137 |
'localhost', '366', |
| 138 |
'End of /NAMES list', |
| 139 |
$ss->{nick}, $chan |
| 140 |
); |
| 141 |
$ss->{chan1} = [ @test_nicks, $ss->{nick} ]; |
| 142 |
|
| 143 |
} elsif ($chan eq $test_chan2) { |
| 144 |
$srv->send_msg ( |
| 145 |
'localhost', '353', |
| 146 |
(join ' ', '@' . $ss->{nick}), |
| 147 |
$ss->{nick}, '=', $chan |
| 148 |
); |
| 149 |
$srv->send_msg ( |
| 150 |
'localhost', '366', |
| 151 |
'End of /NAMES list', |
| 152 |
$ss->{nick}, $chan |
| 153 |
); |
| 154 |
|
| 155 |
$ss->{chan2} = [ '@' . $ss->{nick} ]; |
| 156 |
} |
| 157 |
|
| 158 |
1 |
| 159 |
}, |
| 160 |
disconnect => sub { |
| 161 |
my ($srv, $r) = @_; |
| 162 |
$checks->{srv_disconnect} = $r; |
| 163 |
$c->broadcast; |
| 164 |
1 |
| 165 |
} |
| 166 |
); |
| 167 |
|
| 168 |
$cl->reg_cb ( |
| 169 |
registered => sub { |
| 170 |
my ($cl) = @_; |
| 171 |
$checks->{connected} = $cl->is_connected; |
| 172 |
$checks->{registered} = $cl->nick; |
| 173 |
$checks->{stage} = 1; |
| 174 |
1 |
| 175 |
}, |
| 176 |
irc_ping => sub { |
| 177 |
my ($cl) = @_; |
| 178 |
$checks->{recv_ping} = 1; |
| 179 |
1 |
| 180 |
}, |
| 181 |
irc_join => sub { |
| 182 |
my ($cl, $p) = @_; |
| 183 |
|
| 184 |
if ($checks->{stage} == 1) { |
| 185 |
my ($n, $u, $h) = split_prefix ($p); |
| 186 |
$checks->{stage_1_prefix} = [$n, $u, $h]; |
| 187 |
} |
| 188 |
1 |
| 189 |
}, |
| 190 |
publicmsg => sub { |
| 191 |
my ($cl, $chan, $msg) = @_; |
| 192 |
$checks->{public_reply} = [prefix_nick ($msg), $msg->{trailing}]; |
| 193 |
1 |
| 194 |
}, |
| 195 |
channel_add => sub { |
| 196 |
my ($cl, $chan, @nicks) = @_; |
| 197 |
|
| 198 |
if ($chan eq $test_chan1 && $checks->{stage} == 1) { |
| 199 |
push @{$checks->{stage_1_nicks}}, @nicks; |
| 200 |
|
| 201 |
} elsif ($chan eq $test_chan2 && $checks->{stage} == 2) { |
| 202 |
push @{$checks->{stage_2_nicks}}, @nicks; |
| 203 |
|
| 204 |
} |
| 205 |
|
| 206 |
if ($checks->{stage} == 1 |
| 207 |
&& scalar (@{$checks->{stage_1_nicks}}) == scalar (@test_nicks) + 1) |
| 208 |
{ |
| 209 |
$checks->{stage} = 2; |
| 210 |
$cl->send_srv (JOIN => $test_chan2); |
| 211 |
|
| 212 |
} elsif ($checks->{stage} == 2 && scalar (@{$checks->{stage_2_nicks}}) == 1) { |
| 213 |
$checks->{stage} = 3; |
| 214 |
$checks->{stage_3_channel_list} = [ keys %{$cl->channel_list} ]; |
| 215 |
$cl->disconnect ("done"); |
| 216 |
} |
| 217 |
|
| 218 |
1 |
| 219 |
}, |
| 220 |
disconnect => sub { |
| 221 |
my ($cl, $r) = @_; |
| 222 |
$checks->{cl_disconnect} = $r; |
| 223 |
1 |
| 224 |
} |
| 225 |
); |
| 226 |
|
| 227 |
$cl->set_nick_change_cb (sub { |
| 228 |
my ($n) = @_; |
| 229 |
"$n|" |
| 230 |
}); |
| 231 |
|
| 232 |
$cl->register ($nick, $user, $real); |
| 233 |
$cl->send_chan ($test_chan1, PRIVMSG => "TEST HELLO", $test_chan1); |
| 234 |
$cl->send_srv (JOIN => $test_chan1); |
| 235 |
|
| 236 |
start_watchdog ($c, $checks); |
| 237 |
|
| 238 |
$c->wait; |
| 239 |
|
| 240 |
$nick .= "|_"; |
| 241 |
|
| 242 |
# TEST CHECKS: |
| 243 |
|
| 244 |
$checks = $cl->heap; |
| 245 |
|
| 246 |
ok ($checks->{connected}, "client connected"); |
| 247 |
is ($checks->{registered}, $nick, "client registered with correct nick"); |
| 248 |
is ($checks->{srv_nick}, $nick, "server got nick after 2 collisions"); |
| 249 |
is ($checks->{srv_user}, $user, "server got user"); |
| 250 |
is ($checks->{srv_real}, $real, "server got real"); |
| 251 |
ok ($checks->{recv_ping}, "client got ping"); |
| 252 |
ok ($checks->{recv_pong}, "server got pong"); |
| 253 |
is ($checks->{recv_message}, 'TEST HELLO', "channel message received by server"); |
| 254 |
is ($checks->{public_reply}->[0], $test_chan_msg_srcnick, |
| 255 |
"channel message reply received by client from right nick"); |
| 256 |
is ($checks->{public_reply}->[1], 'TEST REPLY', |
| 257 |
"channel message reply received by client"); |
| 258 |
is ($checks->{stage_1_prefix}->[0], $nick, "stage 1: nick prefix ok"); |
| 259 |
is ($checks->{stage_1_prefix}->[1], $user, "stage 1: user prefix ok"); |
| 260 |
is ($checks->{stage_1_prefix}->[2], 'localhost', "stage 1: host prefix ok"); |
| 261 |
is ( |
| 262 |
(join ' ', sort @{$checks->{stage_1_nicks} || []}), |
| 263 |
(join ' ', sort map { s/^@//; $_ } @test_nicks, $nick), |
| 264 |
"stage 1: successfully joined channel with test users" |
| 265 |
); |
| 266 |
is ( |
| 267 |
(join ' ', sort @{$checks->{stage_2_nicks} || []}), |
| 268 |
(join ' ', sort $nick), |
| 269 |
"stage 2: successfully joined second channel without" |
| 270 |
); |
| 271 |
is ( |
| 272 |
(join ' ', sort @{$checks->{stage_3_channel_list} || []}), |
| 273 |
(join ' ', sort map lc $_, $test_chan1, $test_chan2), |
| 274 |
"stage 3: channel list ok" |
| 275 |
); |
| 276 |
is ($checks->{stage}, 3, "last test stage reached"); |
| 277 |
is ($checks->{cl_disconnect}, 'done', "client disconnected"); |
| 278 |
like ($checks->{srv_disconnect}, qr/EOF/, "server disconnected"); |
| 279 |
ok (!$checks->{watchdog}, "watchdog didn't trigger"); |
| 280 |
} |
