ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Net-Knuddels/eg/knuddels2irc2
Revision: 1.2
Committed: Fri Jan 28 02:42:24 2005 UTC (19 years, 4 months ago) by root
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +2 -1 lines
Log Message:
*** empty log message ***

File Contents

# Content
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