ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Net-Knuddels/eg/knuddels2irc
Revision: 1.2
Committed: Fri Jan 14 23:17:13 2005 UTC (19 years, 5 months ago) by elmex
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +43 -11 lines
Log Message:
further improvements in Knuddels.pm and the knuddels2irc hack

File Contents

# Content
1 #!/usr/bin/perl
2
3 use strict;
4 use lib '../Net-IRC-Server/';
5 use IO::Select;
6 use Socket;
7 use IO::Socket::INET;
8 use Event;
9 use Net::Knuddels;
10 use Net::IRC::Server;
11
12 my $client;
13 my $ircsrv;
14 my %irc_clients;
15
16 my %knuddel_to_irc;
17 my %irc_to_knuddel;
18 my %knuddel_channels;
19 my %irc_chan_to_knuddel;
20
21 my $kn_active;
22
23 my %privmsg_receiver;
24
25 my $server_cl = { nickname => "_", username => "server", hostname => "localhost" };
26
27 sub scan_msg_nicks {
28 my ($msg) = @_;
29
30 for (keys %irc_to_knuddel) {
31 my $n = $irc_to_knuddel{$_}->{knuddelnick};
32 if ($msg =~ s/\b\Q$_\E\b/$n\1/gi) { last }
33 }
34 return $msg;
35 }
36
37 sub ready_irc_server {
38 $ircsrv = Net::IRC::Server->new (srv_prefix => "this.de");
39
40 $ircsrv->set_send_cb (sub {
41 my ($cl, $data, @msg) = @_;
42
43 if (not defined $cl->{socket}) {
44 return 1;
45 }
46
47 }, 'PRIVMSG');
48
49 $ircsrv->set_cmd_cb ('!', sub {
50 my ($cl, $msg) = @_;
51 $privmsg_receiver{$cl->{nickname}} = $cl;
52 });
53
54 $ircsrv->set_cmd_cb ('WHOIS', sub {
55 my ($cl, $msg) = @_;
56 my $kcl = $irc_to_knuddel{lc $msg->{params}->[0]};
57 $client->send_whois ($kcl->{knuddelroom}, $kcl->{knuddelnick});
58
59 return 1;
60 });
61 $ircsrv->set_cmd_cb ('PRIVMSG', sub {
62 my ($cl, $msg) = @_;
63
64 my $targ = $msg->{params}->[0];
65 my $imsg = scan_msg_nicks $msg->{params}->[1];
66
67 $imsg =~ s/(?<!\\)#/\//;
68 $imsg =~ s/^\\#/#/;
69
70 if (defined $knuddel_channels{lc $targ}) {
71
72 $client->send_room_msg (irc_to_room ($targ), $imsg);
73
74 return 1;
75 } elsif (defined $irc_to_knuddel{lc $targ}) {
76 my $cl = $irc_to_knuddel{lc $targ};
77
78 $client->send_priv_msg ($cl->{knuddelnick}, $cl->{knuddelroom}, $imsg);
79 return 1;
80 }
81 return 0;
82 });
83 $ircsrv->set_send_cb (sub {
84 my ($cl, $data) = @_;
85
86 if (defined $cl->{socket}) { # a knuddels-client
87
88 $cl->{socket}->syswrite ($data);
89 print "send $cl->{nickname}> $data"
90 }
91 });
92
93 my $sock = IO::Socket::INET->new(
94 Listen => 5,
95 # LocalAddr => localhost,
96 LocalPort => 6667,
97 Proto => 'tcp',
98 ReuseAddr => 1);
99
100 if (!$sock) { die "Couldn't get listening socket: $!\n" }
101
102 Event->io (
103 fd => $sock,
104 poll => 'r',
105 cb => sub {
106 my $newfh = $sock->accept ();
107 my $addr = $newfh->sockaddr ();
108 $irc_clients{$newfh} = { hostname => inet_ntoa ($addr), socket => $newfh };
109
110 Event->io (
111 fd => $newfh,
112 poll => 'r',
113 cb => sub {
114 my ($e) = @_;
115
116 my $data;
117 my $c = $newfh->sysread ($data, 2048);
118 print "recv $irc_clients{$newfh}->{nickname}> $data";
119
120 if ($c == 0) {
121 $e->w->cancel ();
122 $newfh->close ();
123
124 } else {
125 $ircsrv->feed_irc_data ($irc_clients{$newfh}, $data);
126 }
127 });
128 });
129 }
130 sub connect_knuddels {
131 return if $kn_active; # don't make another login if we are already in
132
133 $client->login;
134 Event->io (
135 fd => $client->fh,
136 poll => 'r',
137 cb => sub {
138 my $e = shift;
139 if (not $client->ready) {
140 $e->w->cancel;
141 }
142 });
143 }
144
145 sub room_to_irc {
146 my $o = $_[0];
147 $_[0] =~ s/[ ]/_/g;
148 $_[0] =~ s/[^a-zA-Z0-9_-]*//g;
149 $irc_chan_to_knuddel{lc "#$_[0]"} = $o;
150 lc "#$_[0]"
151 }
152
153 sub irc_to_room {
154 $irc_chan_to_knuddel{lc $_[0]};
155 }
156
157 sub knuddel_room_msg {
158 my ($room, $user, $msg) = @_;
159
160 $room = room_to_irc $room;
161 my $kncl = $knuddel_channels{$room}->{knd}->{lc $user};
162 $ircsrv->generic_msg ($kncl, $room, "PRIVMSG", $msg);
163 }
164
165 sub knuddel_priv_msg {
166 my ($room, $src, $dst, $msg) = @_;
167
168 my $srccl = $knuddel_to_irc{lc $src};
169 # not of much meaning ;) # my $dstcl = $knuddel_channels{room_to_irc $room}->{knd}->{lc $dst};
170
171 $ircsrv->generic_msg ($srccl, $_, "PRIVMSG", $msg) for keys %privmsg_receiver;
172 }
173
174 sub part_knuddels_nick {
175 my ($knuddels_nick, $room) = @_;
176
177 $room = room_to_irc $room;
178
179 my $kncl = $knuddel_channels{$room}->{knd}->{lc $knuddels_nick};
180 delete $knuddel_channels{$room}->{irc}->{lc $kncl->{nickname}};
181
182 $ircsrv->part_channel ($kncl, $room)
183 }
184
185 sub action_knuddels {
186 my ($room, $action) = @_;
187 $ircsrv->generic_msg ($server_cl,
188 room_to_irc ($room), "PRIVMSG", $action) for keys %privmsg_receiver;
189 }
190
191 sub join_knuddels_nick {
192 my ($knuddel_nick, $age, $gender, $room) = @_;
193 my $orig_knick = $knuddel_nick;
194 $knuddel_nick =~ s/[ ]/_/g;
195 $knuddel_nick =~ s/[<]/{/g;
196 $knuddel_nick =~ s/[>]/}/g;
197 $knuddel_nick =~ s/[=]/^/g;
198 $knuddel_nick =~ s/[&]/\\/g;
199 $knuddel_nick =~ s/[+]/_/g;
200 $knuddel_nick =~ s/[\344]/ae/g;
201 $knuddel_nick =~ s/[\324]/Ae/g;
202 $knuddel_nick =~ s/[\366]/oe/g;
203 $knuddel_nick =~ s/[\346]/Oe/g;
204 $knuddel_nick =~ s/[\374]/ue/g;
205 $knuddel_nick =~ s/[\334]/Ue/g;
206 $knuddel_nick =~ s/[\337]/ss/g;
207 $knuddel_nick =~ s/[^a-zA-Z0-9_-]*//g;
208
209 if (defined $irc_to_knuddel{lc $knuddel_nick}) {
210 my $d = 2;
211
212 while (defined $irc_to_knuddel{lc ($knuddel_nick.$d)}) {
213 $d++;
214 }
215 $knuddel_nick = $knuddel_nick.$d;
216 }
217
218 $irc_to_knuddel{lc $knuddel_nick} = {
219 nickname => $knuddel_nick,
220 username => $knuddel_nick,
221 hostname => "knuddels.de",
222 realname => "$knuddel_nick ($age) [$gender]",
223 knuddelnick => $orig_knick,
224 knuddelroom => $room,
225 registered => 1
226 };
227
228 my $kncl = $knuddel_to_irc{lc $orig_knick} = $irc_to_knuddel{lc $knuddel_nick};
229
230 $room = room_to_irc $room;
231
232 $knuddel_channels{$room}->{knd}->{lc $orig_knick} = $kncl;
233 $knuddel_channels{$room}->{irc}->{lc $knuddel_nick} = $kncl;
234
235 $ircsrv->join_channel ($kncl, $room)
236 }
237
238 ####################################################################################
239 ########################## MAIN START ##############################################
240 ####################################################################################
241
242 $client = new Net::Knuddels::Client PeerAddr => "213.61.5.150:2710";
243
244
245 $client->register (UNHANDLED => sub {
246 use Dumpvalue;
247 print "---\n";
248 Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
249 });
250
251 $client->register (login => sub {
252 $client->set_nick ("Wolke7 2", "Net-Knuddels", "lolfe");
253 $kn_active = 1;
254 });
255
256 $client->register (msg_room => sub {
257 my ($room, $user, $msg) = @_;
258 print "($room) $user: $msg\n";
259 knuddel_room_msg ($room, $user, $msg);
260 });
261
262 $client->register (msg_priv => sub {
263 my ($room, $src, $dst, $msg) = @_;
264 print "($room) ########### $src an $dst: $msg\n";
265 knuddel_priv_msg ($room, $src, $dst, $msg);
266 });
267
268 $client->register (dialog => sub {
269 for my $l (@{$_[0]}) {
270 $l =~ s/\260[^\260]*\260//g;
271 $ircsrv->generic_msg ($server_cl, $_, "PRIVMSG", $l) for keys %privmsg_receiver;
272 }
273 });
274
275 $client->register (join_room => sub {
276 print "$_[1]->{name} joined $_[0]: ".scalar(keys %{$client->{user_lists}->{lc $_[0]}}). " users\n";
277 join_knuddels_nick ($_[1]->{name}, $_[1]->{age}, $_[1]->{gender}, $_[0]);
278 });
279
280 $client->register (action_room => sub {
281 action_knuddels ($_[0], $_[1]);
282 });
283 $client->register (part_room => sub {
284 print "$_[1]->{name} left $_[0]: ".scalar(keys %{$client->{user_lists}->{lc $_[0]}}). " users\n";
285 part_knuddels_nick ($_[1]->{name}, $_[0]);
286 });
287
288 $client->register (user_list => sub {
289 my ($room, $list) = @_;
290 print "***** USER JOIN FUER $room *****\n";
291
292 join_knuddels_nick ($_->{name}, $_->{age}, $_->{gender}, $room)
293 for values %$list;
294
295 print scalar (keys %$list)." users\n";
296 print "********************************\n";
297 });
298
299 $client->register (room_info => sub {
300 my ($room, $ri) = @_;
301 print "ROOM INFO: $room : $ri->{picture}\n";
302 });
303
304 ready_irc_server;
305 connect_knuddels;
306 Event::loop;
307
308
309