[ViewVC] Annotation of: cvs/Net-Knuddels/eg/knuddels2irc

#!/usr/bin/perl

use strict;
use lib '../Net-IRC-Server/';
use IO::Select;
use Socket;
use IO::Socket::INET;
use Event;
use Net::Knuddels;
use Net::IRC::Server;

my $client;
my $ircsrv;
my %irc_clients;

my %knuddel_to_irc;
my %irc_to_knuddel;
my %knuddel_channels;
my %irc_chan_to_knuddel;

my $kn_active; 

my %privmsg_receiver;

my $server_cl = { nickname => "_", username => "server", hostname => "localhost" };

sub scan_msg_nicks {
  my ($msg) = @_;

  for (keys %irc_to_knuddel) {
    my $n = $irc_to_knuddel{$_}->{knuddelnick};
    if ($msg =~ s/\b\Q$_\E\b/$n\1/gi) { last }
  }
  return $msg;
}

sub ready_irc_server {
  $ircsrv = Net::IRC::Server->new (srv_prefix => "this.de");

  $ircsrv->set_send_cb (sub {
    my ($cl, $data, @msg) = @_;

    if (not defined $cl->{socket}) {
      return 1;
    }
    
  }, 'PRIVMSG');

  $ircsrv->set_cmd_cb ('!', sub {
    my ($cl, $msg) = @_;
    $privmsg_receiver{$cl->{nickname}} = $cl;
  });

  $ircsrv->set_cmd_cb ('WHOIS', sub {
    my ($cl, $msg) = @_;
    my $kcl = $irc_to_knuddel{lc $msg->{params}->[0]};
    $client->send_whois ($kcl->{knuddelroom}, $kcl->{knuddelnick});

    return 1;
  });
  $ircsrv->set_cmd_cb ('PRIVMSG', sub {
    my ($cl, $msg) = @_;

    my $targ = $msg->{params}->[0];
    my $imsg = scan_msg_nicks $msg->{params}->[1];

    $imsg =~ s/(?<!\\)#/\//;
    $imsg =~ s/^\\#/#/;
    
    if (defined $knuddel_channels{lc $targ}) {

      $client->send_room_msg (irc_to_room ($targ), $imsg);

      return 1;
    } elsif (defined $irc_to_knuddel{lc $targ}) {
      my $cl = $irc_to_knuddel{lc $targ};

      $client->send_priv_msg ($cl->{knuddelnick}, $cl->{knuddelroom}, $imsg);
      return 1;
    }
    return 0;
  });
  $ircsrv->set_send_cb (sub {
    my ($cl, $data) = @_;

    if (defined $cl->{socket}) { # a knuddels-client

      $cl->{socket}->syswrite ($data);
      print "send $cl->{nickname}> $data"
    }
  });

  my $sock = IO::Socket::INET->new(
      Listen    => 5,
#      LocalAddr => localhost,
      LocalPort => 6667,
      Proto     => 'tcp',
      ReuseAddr => 1);

  if (!$sock) { die "Couldn't get listening socket: $!\n" }

  Event->io (
     fd => $sock, 
     poll => 'r', 
     cb => sub { 
        my $newfh = $sock->accept ();
        my $addr = $newfh->sockaddr ();
        $irc_clients{$newfh} = { hostname => inet_ntoa ($addr), socket => $newfh };

        Event->io (
          fd => $newfh,
          poll => 'r',
          cb => sub {
            my ($e) = @_;

            my $data;
            my $c = $newfh->sysread ($data, 2048);
            print "recv $irc_clients{$newfh}->{nickname}> $data";

            if ($c == 0) {
              $e->w->cancel ();
              $newfh->close ();

            } else {
              $ircsrv->feed_irc_data ($irc_clients{$newfh}, $data);
            }
         });
    });
}
sub connect_knuddels {
  return if $kn_active; # don't make another login if we are already in

  $client->login;
  Event->io (
    fd => $client->fh, 
    poll => 'r', 
    cb => sub { 
      my $e = shift;
      if (not $client->ready) {
        $e->w->cancel;
      }
    });
}

sub room_to_irc {
  my $o = $_[0];
  $_[0] =~ s/[ ]/_/g;
  $_[0] =~ s/[^a-zA-Z0-9_-]*//g;
  $irc_chan_to_knuddel{lc "#$_[0]"} = $o;
  lc "#$_[0]"
}

sub irc_to_room {
  $irc_chan_to_knuddel{lc $_[0]};
}

sub knuddel_room_msg {
  my ($room, $user, $msg) = @_;

  $room = room_to_irc $room;
  my $kncl = $knuddel_channels{$room}->{knd}->{lc $user};
  $ircsrv->generic_msg ($kncl, $room, "PRIVMSG", $msg);
}

sub knuddel_priv_msg {
  my ($room, $src, $dst, $msg) = @_;

  my $srccl = $knuddel_to_irc{lc $src};
  # not of much meaning ;) # my $dstcl = $knuddel_channels{room_to_irc $room}->{knd}->{lc $dst};

  $ircsrv->generic_msg ($srccl, $_, "PRIVMSG", $msg) for keys %privmsg_receiver;
}

sub part_knuddels_nick {
  my ($knuddels_nick, $room) = @_;
  
  $room = room_to_irc $room;
  
  my $kncl = $knuddel_channels{$room}->{knd}->{lc $knuddels_nick};
  delete $knuddel_channels{$room}->{irc}->{lc $kncl->{nickname}};

  $ircsrv->part_channel ($kncl, $room)
}

sub action_knuddels {
  my ($room, $action) = @_;
  $ircsrv->generic_msg ($server_cl,
                        room_to_irc ($room), "PRIVMSG", $action) for keys %privmsg_receiver;
}

sub join_knuddels_nick {
  my ($knuddel_nick, $age, $gender, $room) = @_;
  my $orig_knick = $knuddel_nick;
  $knuddel_nick =~ s/[ ]/_/g;
  $knuddel_nick =~ s/[<]/{/g;
  $knuddel_nick =~ s/[>]/}/g;
  $knuddel_nick =~ s/[=]/^/g;
  $knuddel_nick =~ s/[&]/\\/g;
  $knuddel_nick =~ s/[+]/_/g;
  $knuddel_nick =~ s/[\344]/ae/g;
  $knuddel_nick =~ s/[\324]/Ae/g;
  $knuddel_nick =~ s/[\366]/oe/g;
  $knuddel_nick =~ s/[\346]/Oe/g;
  $knuddel_nick =~ s/[\374]/ue/g;
  $knuddel_nick =~ s/[\334]/Ue/g;
  $knuddel_nick =~ s/[\337]/ss/g;
  $knuddel_nick =~ s/[^a-zA-Z0-9_-]*//g;

  if (defined $irc_to_knuddel{lc $knuddel_nick}) {
    my $d = 2;

    while (defined $irc_to_knuddel{lc ($knuddel_nick.$d)}) {
      $d++;
    }
    $knuddel_nick = $knuddel_nick.$d;
  }

  $irc_to_knuddel{lc $knuddel_nick} = {
    nickname => $knuddel_nick,
    username => $knuddel_nick,
    hostname => "knuddels.de",
    realname => "$knuddel_nick ($age) [$gender]",
    knuddelnick => $orig_knick,
    knuddelroom => $room,
    registered => 1
  };

  my $kncl = $knuddel_to_irc{lc $orig_knick} = $irc_to_knuddel{lc $knuddel_nick};

  $room = room_to_irc $room;

  $knuddel_channels{$room}->{knd}->{lc $orig_knick} = $kncl;
  $knuddel_channels{$room}->{irc}->{lc $knuddel_nick} = $kncl;

  $ircsrv->join_channel ($kncl, $room)
}

####################################################################################
########################## MAIN START ##############################################
####################################################################################

$client = new Net::Knuddels::Client PeerAddr => "213.61.5.150:2710";


$client->register (UNHANDLED => sub {
   use Dumpvalue;
   print "---\n";
   Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
});

$client->register (login => sub {
   $client->set_nick ("Wolke7 2", "Net-Knuddels", "lolfe");
   $kn_active = 1;
});

$client->register (msg_room => sub {
   my ($room, $user, $msg) = @_;
   print "($room) $user: $msg\n";
   knuddel_room_msg ($room, $user, $msg);
});

$client->register (msg_priv => sub {
   my ($room, $src, $dst, $msg) = @_;
   print "($room) ########### $src an $dst: $msg\n";
   knuddel_priv_msg ($room, $src, $dst, $msg);
});

$client->register (dialog => sub {
  for my $l (@{$_[0]}) {
    $l =~ s/\260[^\260]*\260//g;
    $ircsrv->generic_msg ($server_cl, $_, "PRIVMSG", $l) for keys %privmsg_receiver;
  }
});

$client->register (join_room => sub {
  print "$_[1]->{name} joined $_[0]: ".scalar(keys %{$client->{user_lists}->{lc $_[0]}}). " users\n";
  join_knuddels_nick ($_[1]->{name}, $_[1]->{age}, $_[1]->{gender}, $_[0]);
});

$client->register (action_room => sub {
  action_knuddels ($_[0], $_[1]);
});
$client->register (part_room => sub {
  print "$_[1]->{name} left $_[0]: ".scalar(keys %{$client->{user_lists}->{lc $_[0]}}). " users\n";
  part_knuddels_nick ($_[1]->{name}, $_[0]);
});

$client->register (user_list => sub {
   my ($room, $list) = @_;
   print "***** USER JOIN FUER $room *****\n";

  join_knuddels_nick ($_->{name}, $_->{age}, $_->{gender}, $room)
     for values %$list;

   print scalar (keys %$list)." users\n";
   print "********************************\n";
});

$client->register (room_info => sub {
  my ($room, $ri) = @_;
  print "ROOM INFO: $room : $ri->{picture}\n";
});

ready_irc_server;
connect_knuddels;
Event::loop;


Revision:	1.2
Committed:	Fri Jan 14 23:17:13 2005 UTC (21 years, 8 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
#	User	Rev	Content
1	elmex	1.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	elmex	1.2	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	elmex	1.1
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	elmex	1.2	$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	elmex	1.1	$ircsrv->set_cmd_cb ('PRIVMSG', sub {
62			my ($cl, $msg) = @_;
63
64			my $targ = $msg->{params}->[0];
65	elmex	1.2	my $imsg = scan_msg_nicks $msg->{params}->[1];
66
67			$imsg =~ s/(?<!\\)#/\//;
68			$imsg =~ s/^\\#/#/;
69	elmex	1.1
70			if (defined $knuddel_channels{lc $targ}) {
71	elmex	1.2
72	elmex	1.1	$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	elmex	1.2	$ircsrv->generic_msg ($server_cl,
188	elmex	1.1	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	elmex	1.2	$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	elmex	1.1	$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	elmex	1.2	$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	elmex	1.1	$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