1 |
#!/usr/bin/perl |
2 |
|
3 |
package Knuddler; |
4 |
|
5 |
sub new { |
6 |
my $class = shift; |
7 |
my $self = bless { @_ }, $class; |
8 |
$self; |
9 |
} |
10 |
|
11 |
sub set_ircclient { |
12 |
my ($self, $icl) = @_; |
13 |
$self->{icl} = $icl; |
14 |
} |
15 |
|
16 |
sub room_to_irc { |
17 |
my ($self, $room) = @_; |
18 |
my $o = $room; |
19 |
|
20 |
$room =~ s/[ ]/_/g; |
21 |
$room =~ s/[^a-zA-Z0-9_-]*//g; |
22 |
print "r2i '$o' -> '#$room'\n"; |
23 |
$self->{c2r}->{lc "#$room"} = $o; |
24 |
lc "#$room" |
25 |
} |
26 |
|
27 |
sub irc_to_room { |
28 |
my ($self, $ircchan) = @_; |
29 |
if (not defined $self->{c2r}->{lc $ircchan}) { |
30 |
$ircchan =~ s/^#//; |
31 |
$ircchan =~ s/_/ /g; |
32 |
return $ircchan; |
33 |
} |
34 |
return $self->{c2r}->{lc $ircchan}; |
35 |
} |
36 |
|
37 |
sub knuddler_to_nick { |
38 |
my ($self, $knuddler) = @_; |
39 |
|
40 |
return $self->{k2n}->{lc $orig_knick} |
41 |
if defined $self->{k2n}->{lc $orig_knick}; |
42 |
|
43 |
my $orig_knick = $knuddler; |
44 |
$knuddler =~ s/[ ]/_/g; |
45 |
$knuddler =~ s/[<]/{/g; |
46 |
$knuddler =~ s/[>]/}/g; |
47 |
$knuddler =~ s/[=]/^/g; |
48 |
$knuddler =~ s/[&]/\\/g; |
49 |
$knuddler =~ s/[+]/_/g; |
50 |
$knuddler =~ s/[\344]/ae/g; |
51 |
$knuddler =~ s/[\324]/Ae/g; |
52 |
$knuddler =~ s/[\366]/oe/g; |
53 |
$knuddler =~ s/[\346]/Oe/g; |
54 |
$knuddler =~ s/[\374]/ue/g; |
55 |
$knuddler =~ s/[\334]/Ue/g; |
56 |
$knuddler =~ s/[\337]/ss/g; |
57 |
$knuddler =~ s/[^a-zA-Z0-9_-]*//g; |
58 |
|
59 |
|
60 |
if (defined $self->{n2k}->{lc $knuddler}) { |
61 |
my $d = 2; |
62 |
|
63 |
while (defined $self->{n2k}->{lc ($knuddler.$d)}) { |
64 |
$d++; |
65 |
} |
66 |
$knuddler = $knuddler.$d; |
67 |
} |
68 |
|
69 |
$self->{n2k}->{lc $knuddler} = $orig_knick; |
70 |
$self->{k2n}->{lc $orig_knick} = $knuddler; |
71 |
|
72 |
return $knuddler; |
73 |
} |
74 |
|
75 |
sub nick_to_knuddler { |
76 |
my ($self, $nick) = @_; |
77 |
|
78 |
return $self->{n2k}->{lc $nick} |
79 |
if defined $self->{n2k}->{lc $nick}; |
80 |
|
81 |
$nick =~ s/_/ /g; |
82 |
|
83 |
return $nick; |
84 |
} |
85 |
|
86 |
sub activate_client { |
87 |
my ($self, $knuddelnick, $kpass) = @_; |
88 |
$self->{active} = 1; |
89 |
$self->{knuddelnick} = $knuddelnick; |
90 |
$self->{knuddelpass} = $kpass; |
91 |
} |
92 |
|
93 |
sub ircprfx { |
94 |
my ($self, $nick) = @_; |
95 |
$self->{s}->mk_clpref ({ nickname => $nick, username => "knuddler", hostname => "knuddels.de", registered => 1 }) |
96 |
} |
97 |
|
98 |
sub replace_msg_nicks { |
99 |
my ($self, $msg) = @_; |
100 |
|
101 |
for (keys %{$self->{n2k}}) { |
102 |
my $n = $self->{n2k}->{$_}; |
103 |
|
104 |
if ($msg =~ s/\b\Q$_\E\b/$n/gi) { last } |
105 |
} |
106 |
return $msg; |
107 |
} |
108 |
|
109 |
sub handle_room_msg { |
110 |
my ($self, $room, $user, $msg) = @_; |
111 |
|
112 |
$room = $self->room_to_irc ($room); |
113 |
|
114 |
my $kn = $self->knuddler_to_nick ($user); |
115 |
|
116 |
$self->{s}->send_msg ($self->{icl}, $self->ircpre ($kn), "PRIVMSG", $msg, $room); |
117 |
} |
118 |
|
119 |
sub handle_priv_msg { |
120 |
my ($self, $src, $dst, $msg) = @_; |
121 |
return if $src =~ m/^James\d*$/ and $msg =~ m/Funktion.*knuschel.*gibt.*leider.*nich.*/i; |
122 |
|
123 |
my $src = $self->knuddler_to_nick ($src); |
124 |
# not of much meaning ;) # my $dstcl = $knuddel_channels{room_to_irc $room}->{knd}->{lc $dst}; |
125 |
|
126 |
$self->{s}->send_msg ($self->{icl}, $self->ircpre ($src), "PRIVMSG", $msg, $self->{icl}); |
127 |
} |
128 |
|
129 |
sub irc_srvpre { |
130 |
my $self = shift; |
131 |
$self->{s}->mk_clpref ({ nickname => "}", username => "server", hostname => "localhost" }); |
132 |
} |
133 |
|
134 |
sub handle_room_action { |
135 |
my ($self, $room, $action) = @_; |
136 |
$self->{s}->send_msg ($self->{icl}, $self->irc_srvpre (), "PRIVMSG", $action, room_to_irc ($room)); |
137 |
} |
138 |
|
139 |
sub send_exit_room { |
140 |
my ($self, $ircchan) = @_; |
141 |
|
142 |
my $room = $self->irc_to_room ($ircchan); |
143 |
|
144 |
$self->{s}->send_msg ($self->{icl}, $self->{s}->mk_clpref ($self->{icl}), "PART", "parted", $ircchan); |
145 |
|
146 |
delete $self->{rooms}->{lc $room}; |
147 |
delete $self->{channels}->{lc $ircchan}; |
148 |
delete $self->{myrooms}->{lc $room}; |
149 |
|
150 |
$self->{c}->send_exit_room ($self->irc_to_room ($ircchan)); |
151 |
} |
152 |
|
153 |
|
154 |
sub send_enter_room { |
155 |
my ($self, $ircchan) = @_; |
156 |
|
157 |
my $room = $self->irc_to_room ($ircchan); |
158 |
|
159 |
$self->{c}->enter_room ($room, $self->{knuddelsnick}, $self->{knuddelspass}); |
160 |
} |
161 |
|
162 |
sub handle_userlist { |
163 |
my ($self, $room, $list) = @_; |
164 |
|
165 |
for (values %$list) { |
166 |
$self->join_knuddler ($_->{name}, $_->{age}, $_->{gender}, $room); |
167 |
} |
168 |
|
169 |
$self->send_nameslist ($self->room_to_irc ($room)); |
170 |
} |
171 |
|
172 |
sub handle_dialog { |
173 |
my ($self, $d) = @_; |
174 |
for my $l (@$d) { |
175 |
$l =~ s/\260[^\260]*female[^\260]*\260/weiblich/i; |
176 |
$l =~ s/\260[^\260]*male[^\260]*\260/maennlich/i; |
177 |
$l =~ s/\260[^\260]*\260//g; |
178 |
|
179 |
$ircsrv->send_msg ($self->{icl}, $self->irc_srvpre (), "NOTICE", $l, $self->{icl}->{nickname}); |
180 |
} |
181 |
} |
182 |
|
183 |
sub send_nameslist { |
184 |
my ($self, $ic) = @_; |
185 |
|
186 |
my $i = 1; |
187 |
my @part; |
188 |
|
189 |
for (keys %{$self->{channels}->{lc $ic}}) { |
190 |
$i++; |
191 |
push @part, $_; |
192 |
|
193 |
if ($i % 10 == 0) { |
194 |
$self->{s}->send_srv_msg ($self->{icl}, "353", join (' ', @part), $self->{icl}->{nickname}, "=", $ic); |
195 |
@part = (); |
196 |
} |
197 |
} |
198 |
if (@part) { |
199 |
$self->{s}->send_srv_msg ($self->{icl}, "353", join (' ', @part), $self->{icl}->{nickname}, "=", $ic); |
200 |
} |
201 |
$self->{s}->send_srv_msg ($self->{icl}, "366", "End of NAMES list", $self->{icl}->{nickname}, $ic); |
202 |
} |
203 |
|
204 |
sub join_knuddler { |
205 |
my ($self, $knuddler, $age, $gender, $room) = @_; |
206 |
my $ic = $self->room_to_irc ($room); |
207 |
my $in = $self->knuddler_to_nick ($knuddler); |
208 |
|
209 |
my $i = { |
210 |
nickname => $in, |
211 |
knuddelnick => $knuddler, |
212 |
age => $age, |
213 |
gender => $gender |
214 |
}; |
215 |
|
216 |
$self->{channels}->{lc $ic}->{lc $in}->{info} = |
217 |
$self->{rooms}->{lc $room}->{lc $knuddler}->{info} = $i; |
218 |
|
219 |
$self->{s}->send_msg ($self->{icl}, $self->ircpre ($in), "JOIN", $ic); |
220 |
} |
221 |
|
222 |
sub part_knuddler { |
223 |
my ($knuddler, $room) = @_; |
224 |
my $ic = $self->room_to_irc ($room); |
225 |
my $in = $self->knuddler_to_nick ($knuddler); |
226 |
|
227 |
delete $self->{channels}->{lc $ic}->{lc $in}; |
228 |
delete $self->{rooms}->{lc $room}->{lc $knuddler}; |
229 |
|
230 |
$self->{s}->send_msg ($self->{icl}, $self->ircpre ($in), "PART", "parted nick", $ic); |
231 |
} |
232 |
|
233 |
sub handle_room_list { |
234 |
my ($self, $rooms) = @_; |
235 |
$self->room_to_irc ($_) for keys %$rooms; |
236 |
} |
237 |
|
238 |
sub change_room { |
239 |
my ($self, $oroom, $nroom) = @_; |
240 |
|
241 |
my $oic = $self->room_to_irc ($oroom); |
242 |
my $nic = $self->room_to_irc ($nroom); |
243 |
|
244 |
delete $self->{rooms}->{lc $oroom}; |
245 |
delete $self->{channels}->{lc $oic}; |
246 |
|
247 |
delete $self->{myrooms}->{lc $oroom}; |
248 |
$self->{myrooms}->{lc $nroom} = 1; |
249 |
|
250 |
$self->{s}->send_msg ($self->{icl}, $self->{s}->mk_clpref ($self->{icl}), "PART", "change room", $oic); |
251 |
$self->{s}->send_msg ($self->{icl}, $self->{s}->mk_clpref ($self->{icl}), "JOIN", undef, $nic); |
252 |
} |
253 |
|
254 |
sub handle_room_info { |
255 |
my ($self, $room, $ri) = @_; |
256 |
|
257 |
$self->{myrooms}->{lc $room} = 1; |
258 |
$self->{s}->send_msg ($self->{icl}, $self->{s}->mk_clpref ($self->{icl}), "JOIN", undef, $self->room_to_irc ($room)); |
259 |
} |
260 |
|
261 |
|
262 |
sub find_any_room { |
263 |
my ($self) = @_; |
264 |
|
265 |
return (keys %{$self->{myrooms}})[0]; |
266 |
} |
267 |
|
268 |
sub send_keepalive_client { |
269 |
my ($self) = @_; |
270 |
my $r = $self->find_any_room (); |
271 |
|
272 |
print "KNUDDELS PING\n"; |
273 |
return if not defined $r; |
274 |
print "PING TO $f->{knuddelroom} $f->{knuddelnick}\n"; |
275 |
|
276 |
$self->{c}->send_room_msg ($r, "/knuschel"); |
277 |
} |
278 |
|
279 |
package main; |
280 |
use strict; |
281 |
use lib '../Net-IRC-Server/'; |
282 |
use IO::Select; |
283 |
use Socket; |
284 |
use IO::Socket::INET; |
285 |
use Event; |
286 |
use Net::Knuddels; |
287 |
use Net::IRC::Server; |
288 |
use YAML; |
289 |
|
290 |
my %CFG = ( |
291 |
server_cl_nick => "_", |
292 |
server_cl_user => "server", |
293 |
server_cl_host => "localhost", |
294 |
server_prefix => "test.de", |
295 |
|
296 |
knuddel_nick => "Net-Knuddels", |
297 |
knuddel_pass => "lolfe", |
298 |
knuddel_chan => "Flirt Private", |
299 |
); |
300 |
|
301 |
scan_config (); |
302 |
|
303 |
my $KDL; |
304 |
my $client; |
305 |
my $ircsrv; |
306 |
my $irc_client; |
307 |
|
308 |
sub scan_config { |
309 |
my $config = "$ENV{HOME}/.knuddels2irc2.rc"; |
310 |
|
311 |
if (! -e $config) { return; } |
312 |
|
313 |
my $h = YAML::LoadFile $config; |
314 |
|
315 |
if (defined $h and ref $h eq "HASH") { |
316 |
%CFG = (%CFG, %$h); |
317 |
} else { |
318 |
die "$config is not a map!"; |
319 |
} |
320 |
} |
321 |
|
322 |
sub ready_irc_server { |
323 |
$ircsrv = Net::IRC::Server->new (srv_prefix => $CFG{server_prefix}); |
324 |
|
325 |
$ircsrv->set_send_cb (sub { |
326 |
my ($cl, $data, @msg) = @_; |
327 |
|
328 |
if (not defined $cl->{socket}) { |
329 |
return 1; |
330 |
} |
331 |
|
332 |
}, 'PRIVMSG'); |
333 |
|
334 |
$ircsrv->set_cmd_cb ('*', sub { |
335 |
my $c = uc $_[1]->{command}; |
336 |
return 1; |
337 |
}); # default handler ;) Overwrite _anything_ the server does |
338 |
|
339 |
$ircsrv->set_cmd_cb ('PING', sub { |
340 |
my ($cl, $msg) = @_; |
341 |
$ircsrv->send_srv_msg ($cl, "PONG", $msg->{params}->[0]); |
342 |
}); |
343 |
$ircsrv->set_cmd_cb ('NICK', sub { |
344 |
my ($cl, $msg) = @_; |
345 |
$cl->{nickname} = $msg->{params}[0]; |
346 |
}); |
347 |
|
348 |
$ircsrv->set_cmd_cb ('USER', sub { |
349 |
my ($cl, $msg) = @_; |
350 |
$cl->{username} = $msg->{params}->[0]; |
351 |
$cl->{realname} = $msg->{params}->[3]; |
352 |
|
353 |
$ircsrv->send_srv_msg ($irc_client, |
354 |
"001", |
355 |
"Welcome to NET::IRCServer! " |
356 |
. $ircsrv->mk_clpref ($cl), |
357 |
$cl->{nickname}); |
358 |
}); |
359 |
|
360 |
$ircsrv->set_cmd_cb ('NAMES', sub { |
361 |
my ($cl, $msg) = @_; |
362 |
return if not defined $msg->{params}[0]; |
363 |
$KDL->send_nameslist ($msg->{params}[0]); |
364 |
}); |
365 |
|
366 |
$ircsrv->set_cmd_cb ('PART', sub { |
367 |
my ($cl, $msg) = @_; |
368 |
$KDL->send_exit_room ($msg->{params}[0]); |
369 |
}); |
370 |
|
371 |
$ircsrv->set_cmd_cb ('JOIN', sub { |
372 |
my ($cl, $msg) = @_; |
373 |
print "ENTER ROOM: $msg->{params}[0]\n"; |
374 |
$KDL->send_enter_room ($msg->{params}[0]); |
375 |
}); |
376 |
|
377 |
$ircsrv->set_cmd_cb ('LIST', sub { |
378 |
|
379 |
# for (sort { $a cmp $b } keys %knuddel_channels) { |
380 |
# my $chan = $knuddel_channels{$_}; |
381 |
# my $c = room_to_irc ($chan->{name}); |
382 |
|
383 |
# $ircsrv->send_srv_msg ( |
384 |
# $irc_client, |
385 |
# "322", |
386 |
# $chan->{name} . ($chan->{full_flag} ? " (full)" : ""), |
387 |
# $irc_client->{nickname}, |
388 |
# "$c", |
389 |
# $chan->{user_count}); |
390 |
# } |
391 |
# $ircsrv->send_srv_msg ($irc_client, "323", "End of LIST", $irc_client->{nickname}); |
392 |
}); |
393 |
|
394 |
# $ircsrv->set_cmd_cb ('WHOIS', sub { |
395 |
# my ($cl, $msg) = @_; |
396 |
# my $kcl = $irc_to_knuddel{lc $msg->{params}->[0]}; |
397 |
# |
398 |
# $client->send_whois ($kcl->{knuddelroom}, $kcl->{knuddelnick}); |
399 |
# |
400 |
# return 1; |
401 |
# }); |
402 |
|
403 |
$ircsrv->set_cmd_cb ('PRIVMSG', sub { |
404 |
=pod |
405 |
my ($cl, $msg) = @_; |
406 |
|
407 |
my $targ = $msg->{params}->[0]; |
408 |
my $imsg = scan_msg_nicks $msg->{params}->[1]; |
409 |
|
410 |
$imsg =~ s/(?<!\\)#/\//; |
411 |
$imsg =~ s/^\\#/#/; |
412 |
|
413 |
if (defined $knuddel_channels{lc $targ}) { |
414 |
|
415 |
$client->send_room_msg (irc_to_room ($targ), $imsg); |
416 |
|
417 |
return 1; |
418 |
} elsif (defined $irc_to_knuddel{lc $targ}) { |
419 |
my $cl = $irc_to_knuddel{lc $targ}; |
420 |
|
421 |
$client->send_priv_msg ($cl->{knuddelnick}, $cl->{knuddelroom}, $imsg); |
422 |
return 1; |
423 |
} |
424 |
return 0; |
425 |
=cut |
426 |
}); |
427 |
|
428 |
$ircsrv->set_send_cb (sub { |
429 |
my ($cl, $data) = @_; |
430 |
|
431 |
if (defined $cl->{socket}) { # a knuddels-client |
432 |
|
433 |
$cl->{socket}->syswrite ($data); |
434 |
print "send $cl->{nickname}> $data" |
435 |
} |
436 |
}); |
437 |
|
438 |
my $sock = IO::Socket::INET->new( |
439 |
Listen => 5, |
440 |
# LocalAddr => localhost, |
441 |
LocalPort => 6667, |
442 |
Proto => 'tcp', |
443 |
ReuseAddr => 1); |
444 |
|
445 |
if (!$sock) { die "Couldn't get listening socket: $!\n" } |
446 |
|
447 |
Event->io ( |
448 |
fd => $sock, |
449 |
poll => 'r', |
450 |
cb => sub { |
451 |
my $newfh = $sock->accept (); |
452 |
my $addr = $newfh->sockaddr (); |
453 |
|
454 |
if (defined $irc_client) { |
455 |
$newfh->close; |
456 |
print "NEWCL\n"; |
457 |
return; |
458 |
} |
459 |
|
460 |
$irc_client = { hostname => inet_ntoa ($addr), socket => $newfh }; |
461 |
$KDL->set_ircclient ($irc_client); |
462 |
|
463 |
Event->io ( |
464 |
fd => $newfh, |
465 |
poll => 'r', |
466 |
cb => sub { |
467 |
my ($e) = @_; |
468 |
|
469 |
my $data; |
470 |
my $c = $newfh->sysread ($data, 2048); |
471 |
print "recv $irc_client->{nickname}> $data"; |
472 |
|
473 |
if ($c == 0) { |
474 |
$e->w->cancel (); |
475 |
$newfh->close (); |
476 |
|
477 |
} else { |
478 |
$ircsrv->feed_irc_data ($irc_client, $data); |
479 |
} |
480 |
}); |
481 |
}); |
482 |
} |
483 |
sub connect_knuddels { |
484 |
$client->login; |
485 |
Event->io ( |
486 |
fd => $client->fh, |
487 |
poll => 'r', |
488 |
cb => sub { |
489 |
my $e = shift; |
490 |
|
491 |
if (not $client->ready) { |
492 |
$e->w->cancel; |
493 |
} |
494 |
}); |
495 |
} |
496 |
|
497 |
#################################################################################### |
498 |
########################## MAIN START ############################################## |
499 |
#################################################################################### |
500 |
|
501 |
$client = new Net::Knuddels::Client PeerAddr => "213.61.5.150:2710"; |
502 |
$KDL = new Knuddler c => $client, s => $ircsrv; |
503 |
|
504 |
|
505 |
$client->register (UNHANDLED => sub { |
506 |
use Dumpvalue; |
507 |
print "---\n"; |
508 |
Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]); |
509 |
}); |
510 |
|
511 |
$client->register (login => sub { |
512 |
$KDL->activate_client; |
513 |
|
514 |
Event->timer (interval => 60, cb => sub { |
515 |
$KDL->send_keepalive_client (); |
516 |
}); |
517 |
}); |
518 |
|
519 |
$client->register (msg_room => sub { |
520 |
my ($room, $user, $msg) = @_; |
521 |
print "($room) =========== $user: $msg\n"; |
522 |
$KDL->handle_room_msg ($room, $user, $msg); |
523 |
}); |
524 |
|
525 |
$client->register (msg_priv => sub { |
526 |
my ($room, $src, $dst, $msg) = @_; |
527 |
print "($room) ########### $src an $dst: $msg\n"; |
528 |
$KDL->handle_priv_msg ($room, $src, $dst, $msg); |
529 |
}); |
530 |
|
531 |
$client->register (join_room => sub { |
532 |
print "$_[1]->{name} joined $_[0]: ".scalar(keys %{$client->{user_lists}->{lc $_[0]}}). " users\n"; |
533 |
$KDL->join_knuddler ($_[1]->{name}, $_[1]->{age}, $_[1]->{gender}, $_[0]); |
534 |
}); |
535 |
|
536 |
$client->register (action_room => sub { |
537 |
$KDL->handle_room_action ($_[0], $_[1]); |
538 |
}); |
539 |
|
540 |
$client->register (part_room => sub { |
541 |
print "$_[1]->{name} left $_[0]: ".scalar(keys %{$client->{user_lists}->{lc $_[0]}}). " users\n"; |
542 |
$KDL->part_knuddler ($_[1]->{name}, $_[0]); |
543 |
}); |
544 |
|
545 |
$client->register (user_list => sub { |
546 |
my ($room, $list) = @_; |
547 |
print "***** USER JOIN FUER $room *****\n"; |
548 |
print scalar (keys %$list)." users\n"; |
549 |
print "********************************\n"; |
550 |
|
551 |
$KDL->handle_userlist ($room); |
552 |
}); |
553 |
|
554 |
$client->register (room_info => sub { |
555 |
my ($room, $ri) = @_; |
556 |
print "ROOM INFO: $room : $ri->{picture}\n"; |
557 |
$KDL->handle_room_info ($room, $ri); |
558 |
}); |
559 |
|
560 |
$client->register (change_room => sub { |
561 |
my ($r, $nr) = @_; |
562 |
$KDL->change_room ($r, $nr); |
563 |
}); |
564 |
|
565 |
$client->register (room_list => sub { |
566 |
my ($room_hash) = @_; |
567 |
$KDL->handle_room_list ($room_hash); |
568 |
}); |
569 |
|
570 |
$client->register (dialog => sub { |
571 |
$KDL->handle_dialog ($_[0]); |
572 |
}); |
573 |
|
574 |
ready_irc_server; |
575 |
connect_knuddels; |
576 |
Event::loop; |
577 |
|
578 |
|
579 |
|