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