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

#!/usr/bin/perl

package Knuddler;

sub new {
   my $class = shift;
   my $self = bless { @_ }, $class;
   $self;
}

sub set_ircclient {
  my ($self, $icl) = @_;
  $self->{icl} = $icl;
}

sub room_to_irc {
  my ($self, $room) = @_;
  my $o = $room;

  $room =~ s/[ ]/_/g;
  $room =~ s/[^a-zA-Z0-9_-]*//g;
  print "r2i '$o' -> '#$room'\n";
  $self->{c2r}->{lc "#$room"} = $o;
  lc "#$room"
}

sub irc_to_room {
  my ($self, $ircchan) = @_;
  if (not defined $self->{c2r}->{lc $ircchan}) {
    $ircchan =~ s/^#//;
    $ircchan =~ s/_/ /g;
    return $ircchan;
  }
  return $self->{c2r}->{lc $ircchan};
}

sub knuddler_to_nick {
  my ($self, $knuddler) = @_;

  return $self->{k2n}->{lc $orig_knick}
    if defined $self->{k2n}->{lc $orig_knick};

  my $orig_knick = $knuddler;
  $knuddler =~ s/[ ]/_/g;
  $knuddler =~ s/[<]/{/g;
  $knuddler =~ s/[>]/}/g;
  $knuddler =~ s/[=]/^/g;
  $knuddler =~ s/[&]/\\/g;
  $knuddler =~ s/[+]/_/g;
  $knuddler =~ s/[\344]/ae/g;
  $knuddler =~ s/[\324]/Ae/g;
  $knuddler =~ s/[\366]/oe/g;
  $knuddler =~ s/[\346]/Oe/g;
  $knuddler =~ s/[\374]/ue/g;
  $knuddler =~ s/[\334]/Ue/g;
  $knuddler =~ s/[\337]/ss/g;
  $knuddler =~ s/[^a-zA-Z0-9_-]*//g;


  if (defined $self->{n2k}->{lc $knuddler}) {
    my $d = 2;

    while (defined $self->{n2k}->{lc ($knuddler.$d)}) {
      $d++;
    }
    $knuddler = $knuddler.$d;
  }

  $self->{n2k}->{lc $knuddler} = $orig_knick;
  $self->{k2n}->{lc $orig_knick} = $knuddler;

  return $knuddler;
}

sub nick_to_knuddler {
  my ($self, $nick) = @_;

  return $self->{n2k}->{lc $nick} 
    if defined $self->{n2k}->{lc $nick};

  $nick =~ s/_/ /g;

  return $nick;
}

sub activate_client {
  my ($self, $knuddelnick, $kpass) = @_;
  $self->{active} = 1;
  $self->{knuddelnick} = $knuddelnick;
  $self->{knuddelpass} = $kpass;
}

sub ircprfx {
  my ($self, $nick) = @_;
  $self->{s}->mk_clpref ({ nickname => $nick, username => "knuddler", hostname => "knuddels.de", registered => 1 })
}

sub replace_msg_nicks {
  my ($self, $msg) = @_;

  for (keys %{$self->{n2k}}) {
    my $n = $self->{n2k}->{$_};

    if ($msg =~ s/\b\Q$_\E\b/$n/gi) { last }
  }
  return $msg;
}

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

  $room = $self->room_to_irc ($room);

  my $kn = $self->knuddler_to_nick ($user);

  $self->{s}->send_msg ($self->{icl}, $self->ircpre ($kn), "PRIVMSG", $msg, $room);
}

sub handle_priv_msg {
  my ($self, $src, $dst, $msg) = @_;
  return if $src =~ m/^James\d*$/ and $msg =~ m/Funktion.*knuschel.*gibt.*leider.*nich.*/i;

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

  $self->{s}->send_msg ($self->{icl}, $self->ircpre ($src), "PRIVMSG", $msg, $self->{icl});
}

sub irc_srvpre {
  my $self = shift;
  $self->{s}->mk_clpref ({ nickname => "}", username => "server", hostname => "localhost" });
}

sub handle_room_action {
  my ($self, $room, $action) = @_;
  $self->{s}->send_msg ($self->{icl}, $self->irc_srvpre (), "PRIVMSG", $action, room_to_irc ($room));
}

sub send_exit_room {
  my ($self, $ircchan) = @_;

  my $room = $self->irc_to_room ($ircchan);

  $self->{s}->send_msg ($self->{icl}, $self->{s}->mk_clpref ($self->{icl}), "PART", "parted", $ircchan);

  delete $self->{rooms}->{lc $room};
  delete $self->{channels}->{lc $ircchan};
  delete $self->{myrooms}->{lc $room};

  $self->{c}->send_exit_room ($self->irc_to_room ($ircchan));
}


sub send_enter_room {
  my ($self, $ircchan) = @_;

  my $room = $self->irc_to_room ($ircchan);

  $self->{c}->enter_room ($room, $self->{knuddelsnick}, $self->{knuddelspass});
}

sub handle_userlist {
  my ($self, $room, $list) = @_;
  
  for (values %$list) {
    $self->join_knuddler ($_->{name}, $_->{age}, $_->{gender}, $room);
  }

  $self->send_nameslist ($self->room_to_irc ($room));
}

sub handle_dialog {
  my ($self, $d) = @_;
  for my $l (@$d) {
    $l =~ s/\260[^\260]*female[^\260]*\260/weiblich/i;
    $l =~ s/\260[^\260]*male[^\260]*\260/maennlich/i;
    $l =~ s/\260[^\260]*\260//g;

    $ircsrv->send_msg ($self->{icl}, $self->irc_srvpre (), "NOTICE", $l, $self->{icl}->{nickname});
  }
}

sub send_nameslist {
  my ($self, $ic) = @_;

  my $i = 1;
  my @part;
  
  for (keys %{$self->{channels}->{lc $ic}}) {
    $i++;
    push @part, $_;

    if ($i % 10 == 0) {
      $self->{s}->send_srv_msg ($self->{icl}, "353", join (' ', @part), $self->{icl}->{nickname}, "=", $ic);
      @part = ();
    }
  }
  if (@part) {
   $self->{s}->send_srv_msg ($self->{icl}, "353", join (' ', @part), $self->{icl}->{nickname}, "=", $ic);
  }
  $self->{s}->send_srv_msg ($self->{icl}, "366", "End of NAMES list", $self->{icl}->{nickname}, $ic);
}

sub join_knuddler {
  my ($self, $knuddler, $age, $gender, $room) = @_;
  my $ic = $self->room_to_irc ($room);
  my $in = $self->knuddler_to_nick ($knuddler);

  my $i = {
    nickname => $in,
    knuddelnick => $knuddler,
    age => $age,
    gender => $gender
  };

  $self->{channels}->{lc $ic}->{lc $in}->{info} = 
    $self->{rooms}->{lc $room}->{lc $knuddler}->{info} = $i;

  $self->{s}->send_msg ($self->{icl}, $self->ircpre ($in), "JOIN", $ic);
}

sub part_knuddler {
  my ($knuddler, $room) = @_;
  my $ic = $self->room_to_irc ($room);
  my $in = $self->knuddler_to_nick ($knuddler);

  delete $self->{channels}->{lc $ic}->{lc $in};
  delete $self->{rooms}->{lc $room}->{lc $knuddler};

  $self->{s}->send_msg ($self->{icl}, $self->ircpre ($in), "PART", "parted nick", $ic);
}

sub handle_room_list {
  my ($self, $rooms) = @_;
  $self->room_to_irc ($_) for keys %$rooms;
}

sub change_room {
  my ($self, $oroom, $nroom) = @_;

  my $oic = $self->room_to_irc ($oroom);
  my $nic = $self->room_to_irc ($nroom);

  delete $self->{rooms}->{lc $oroom};
  delete $self->{channels}->{lc $oic};

  delete $self->{myrooms}->{lc $oroom};
  $self->{myrooms}->{lc $nroom} = 1;

  $self->{s}->send_msg ($self->{icl}, $self->{s}->mk_clpref ($self->{icl}), "PART", "change room", $oic);
  $self->{s}->send_msg ($self->{icl}, $self->{s}->mk_clpref ($self->{icl}), "JOIN", undef, $nic);
}

sub handle_room_info {
  my ($self, $room, $ri) = @_;

  $self->{myrooms}->{lc $room} = 1;
  $self->{s}->send_msg ($self->{icl}, $self->{s}->mk_clpref ($self->{icl}), "JOIN", undef, $self->room_to_irc ($room));
}


sub find_any_room {
  my ($self) = @_;

  return (keys %{$self->{myrooms}})[0];
}

sub send_keepalive_client {
  my ($self) = @_;
  my $r = $self->find_any_room ();

  print "KNUDDELS PING\n";
  return if not defined $r;
  print "PING TO $f->{knuddelroom} $f->{knuddelnick}\n";
  
  $self->{c}->send_room_msg ($r, "/knuschel");
}

package main;
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;
use YAML;

my %CFG = (
  server_cl_nick => "_",
  server_cl_user => "server",
  server_cl_host => "localhost",
  server_prefix  => "test.de",

  knuddel_nick   => "Net-Knuddels",
  knuddel_pass   => "lolfe",
  knuddel_chan   => "Flirt Private",
);

scan_config ();

my $KDL;
my $client;
my $ircsrv;
my $irc_client;

sub scan_config {
  my $config = "$ENV{HOME}/.knuddels2irc2.rc";

  if (! -e $config) { return; }
  
  my $h = YAML::LoadFile $config;

  if (defined $h and ref $h eq "HASH") {
    %CFG = (%CFG, %$h);
  } else {
    die "$config is not a map!";
  }
}

sub ready_irc_server {
  $ircsrv = Net::IRC::Server->new (srv_prefix => $CFG{server_prefix});

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

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

  $ircsrv->set_cmd_cb ('*', sub { 
    my $c = uc $_[1]->{command};
    return 1;
  }); # default handler ;) Overwrite _anything_ the server does

  $ircsrv->set_cmd_cb ('PING', sub {
    my ($cl, $msg) = @_;
    $ircsrv->send_srv_msg ($cl, "PONG", $msg->{params}->[0]);
  });
  $ircsrv->set_cmd_cb ('NICK', sub {
    my ($cl, $msg) = @_;
    $cl->{nickname} = $msg->{params}[0];
  });

  $ircsrv->set_cmd_cb ('USER', sub {
    my ($cl, $msg) = @_;
    $cl->{username} = $msg->{params}->[0];
    $cl->{realname} = $msg->{params}->[3];

    $ircsrv->send_srv_msg ($irc_client, 
                     "001", 
                     "Welcome to NET::IRCServer! " 
                     . $ircsrv->mk_clpref ($cl), 
                     $cl->{nickname});
  });

  $ircsrv->set_cmd_cb ('NAMES', sub {
    my ($cl, $msg) = @_;
    return if not defined $msg->{params}[0];
    $KDL->send_nameslist ($msg->{params}[0]);
  });

  $ircsrv->set_cmd_cb ('PART', sub {
    my ($cl, $msg) = @_;
    $KDL->send_exit_room ($msg->{params}[0]);
  });

  $ircsrv->set_cmd_cb ('JOIN', sub {
    my ($cl, $msg) = @_;
    print "ENTER ROOM: $msg->{params}[0]\n";
    $KDL->send_enter_room ($msg->{params}[0]);
  });

  $ircsrv->set_cmd_cb ('LIST', sub {

#    for (sort { $a cmp $b } keys %knuddel_channels) {
#      my $chan = $knuddel_channels{$_};
 #     my $c = room_to_irc ($chan->{name});

  #    $ircsrv->send_srv_msg (
   #      $irc_client,
    #     "322",
     #    $chan->{name} . ($chan->{full_flag} ? " (full)" : ""), 
      #   $irc_client->{nickname},
       #  "$c", 
#         $chan->{user_count});
 #   }
  #  $ircsrv->send_srv_msg ($irc_client, "323", "End of LIST", $irc_client->{nickname});
  });

#  $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 {
=pod
    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;
=cut
  });

  $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 ();
        
        if (defined $irc_client) {
          $newfh->close;
          print "NEWCL\n";
          return;
        }

        $irc_client = { hostname => inet_ntoa ($addr), socket => $newfh };
        $KDL->set_ircclient ($irc_client);

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

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

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

            } else {
              $ircsrv->feed_irc_data ($irc_client, $data);
            }
         });
    });
}
sub connect_knuddels {
  $client->login;
  Event->io (
    fd => $client->fh, 
    poll => 'r', 
    cb => sub { 
      my $e = shift;

      if (not $client->ready) {
        $e->w->cancel;
      }
    });
}

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

$client = new Net::Knuddels::Client PeerAddr => "213.61.5.150:2710";
$KDL    = new Knuddler c => $client, s => $ircsrv;


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

$client->register (login => sub {
   $KDL->activate_client;

   Event->timer (interval => 60, cb => sub {
     $KDL->send_keepalive_client ();
   });
});

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

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

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

$client->register (action_room => sub {
  $KDL->handle_room_action ($_[0], $_[1]);
});

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

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

   $KDL->handle_userlist ($room);
});

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

$client->register (change_room => sub {
  my ($r, $nr) = @_;
  $KDL->change_room ($r, $nr);
});

$client->register (room_list => sub {
  my ($room_hash) = @_;
  $KDL->handle_room_list ($room_hash);
});

$client->register (dialog => sub {
  $KDL->handle_dialog ($_[0]);
});

ready_irc_server;
connect_knuddels;
Event::loop;


Revision:	1.2
Committed:	Fri Jan 28 02:42:24 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.1:	+2 -1 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	elmex	1.1	#!/usr/bin/perl
2	root	1.2
3	elmex	1.1	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	root	1.2	my $config = "$ENV{HOME}/.knuddels2irc2.rc";
310	elmex	1.1
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