[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.1
Committed:	Mon Jan 24 01:42:06 2005 UTC (21 years, 7 months ago) by elmex
Branch:	MAIN
Log Message:	new knuddels irc client
#	User	Rev	Content
1	elmex	1.1	#!/usr/bin/perl
2			package Knuddler;
3
4			sub new {
5			my $class = shift;
6			my $self = bless { @_ }, $class;
7			$self;
8			}
9
10			sub set_ircclient {
11			my ($self, $icl) = @_;
12			$self->{icl} = $icl;
13			}
14
15			sub room_to_irc {
16			my ($self, $room) = @_;
17			my $o = $room;
18
19			$room =~ s/[ ]/_/g;
20			$room =~ s/[^a-zA-Z0-9_-]*//g;
21			print "r2i '$o' -> '#$room'\n";
22			$self->{c2r}->{lc "#$room"} = $o;
23			lc "#$room"
24			}
25
26			sub irc_to_room {
27			my ($self, $ircchan) = @_;
28			if (not defined $self->{c2r}->{lc $ircchan}) {
29			$ircchan =~ s/^#//;
30			$ircchan =~ s/_/ /g;
31			return $ircchan;
32			}
33			return $self->{c2r}->{lc $ircchan};
34			}
35
36			sub knuddler_to_nick {
37			my ($self, $knuddler) = @_;
38
39			return $self->{k2n}->{lc $orig_knick}
40			if defined $self->{k2n}->{lc $orig_knick};
41
42			my $orig_knick = $knuddler;
43			$knuddler =~ s/[ ]/_/g;
44			$knuddler =~ s/[<]/{/g;
45			$knuddler =~ s/[>]/}/g;
46			$knuddler =~ s/[=]/^/g;
47			$knuddler =~ s/[&]/\\/g;
48			$knuddler =~ s/[+]/_/g;
49			$knuddler =~ s/[\344]/ae/g;
50			$knuddler =~ s/[\324]/Ae/g;
51			$knuddler =~ s/[\366]/oe/g;
52			$knuddler =~ s/[\346]/Oe/g;
53			$knuddler =~ s/[\374]/ue/g;
54			$knuddler =~ s/[\334]/Ue/g;
55			$knuddler =~ s/[\337]/ss/g;
56			$knuddler =~ s/[^a-zA-Z0-9_-]*//g;
57
58
59			if (defined $self->{n2k}->{lc $knuddler}) {
60			my $d = 2;
61
62			while (defined $self->{n2k}->{lc ($knuddler.$d)}) {
63			$d++;
64			}
65			$knuddler = $knuddler.$d;
66			}
67
68			$self->{n2k}->{lc $knuddler} = $orig_knick;
69			$self->{k2n}->{lc $orig_knick} = $knuddler;
70
71			return $knuddler;
72			}
73
74			sub nick_to_knuddler {
75			my ($self, $nick) = @_;
76
77			return $self->{n2k}->{lc $nick}
78			if defined $self->{n2k}->{lc $nick};
79
80			$nick =~ s/_/ /g;
81
82			return $nick;
83			}
84
85			sub activate_client {
86			my ($self, $knuddelnick, $kpass) = @_;
87			$self->{active} = 1;
88			$self->{knuddelnick} = $knuddelnick;
89			$self->{knuddelpass} = $kpass;
90			}
91
92			sub ircprfx {
93			my ($self, $nick) = @_;
94			$self->{s}->mk_clpref ({ nickname => $nick, username => "knuddler", hostname => "knuddels.de", registered => 1 })
95			}
96
97			sub replace_msg_nicks {
98			my ($self, $msg) = @_;
99
100			for (keys %{$self->{n2k}}) {
101			my $n = $self->{n2k}->{$_};
102
103			if ($msg =~ s/\b\Q$_\E\b/$n/gi) { last }
104			}
105			return $msg;
106			}
107
108			sub handle_room_msg {
109			my ($self, $room, $user, $msg) = @_;
110
111			$room = $self->room_to_irc ($room);
112
113			my $kn = $self->knuddler_to_nick ($user);
114
115			$self->{s}->send_msg ($self->{icl}, $self->ircpre ($kn), "PRIVMSG", $msg, $room);
116			}
117
118			sub handle_priv_msg {
119			my ($self, $src, $dst, $msg) = @_;
120			return if $src =~ m/^James\d$/ and $msg =~ m/Funktion.knuschel.gibt.leider.nich./i;
121
122			my $src = $self->knuddler_to_nick ($src);
123			# not of much meaning ;) # my $dstcl = $knuddel_channels{room_to_irc $room}->{knd}->{lc $dst};
124
125			$self->{s}->send_msg ($self->{icl}, $self->ircpre ($src), "PRIVMSG", $msg, $self->{icl});
126			}
127
128			sub irc_srvpre {
129			my $self = shift;
130			$self->{s}->mk_clpref ({ nickname => "}", username => "server", hostname => "localhost" });
131			}
132
133			sub handle_room_action {
134			my ($self, $room, $action) = @_;
135			$self->{s}->send_msg ($self->{icl}, $self->irc_srvpre (), "PRIVMSG", $action, room_to_irc ($room));
136			}
137
138			sub send_exit_room {
139			my ($self, $ircchan) = @_;
140
141			my $room = $self->irc_to_room ($ircchan);
142
143			$self->{s}->send_msg ($self->{icl}, $self->{s}->mk_clpref ($self->{icl}), "PART", "parted", $ircchan);
144
145			delete $self->{rooms}->{lc $room};
146			delete $self->{channels}->{lc $ircchan};
147			delete $self->{myrooms}->{lc $room};
148
149			$self->{c}->send_exit_room ($self->irc_to_room ($ircchan));
150			}
151
152
153			sub send_enter_room {
154			my ($self, $ircchan) = @_;
155
156			my $room = $self->irc_to_room ($ircchan);
157
158			$self->{c}->enter_room ($room, $self->{knuddelsnick}, $self->{knuddelspass});
159			}
160
161			sub handle_userlist {
162			my ($self, $room, $list) = @_;
163
164			for (values %$list) {
165			$self->join_knuddler ($_->{name}, $_->{age}, $_->{gender}, $room);
166			}
167
168			$self->send_nameslist ($self->room_to_irc ($room));
169			}
170
171			sub handle_dialog {
172			my ($self, $d) = @_;
173			for my $l (@$d) {
174			$l =~ s/\260[^\260]female[^\260]\260/weiblich/i;
175			$l =~ s/\260[^\260]male[^\260]\260/maennlich/i;
176			$l =~ s/\260[^\260]*\260//g;
177
178			$ircsrv->send_msg ($self->{icl}, $self->irc_srvpre (), "NOTICE", $l, $self->{icl}->{nickname});
179			}
180			}
181
182			sub send_nameslist {
183			my ($self, $ic) = @_;
184
185			my $i = 1;
186			my @part;
187
188			for (keys %{$self->{channels}->{lc $ic}}) {
189			$i++;
190			push @part, $_;
191
192			if ($i % 10 == 0) {
193			$self->{s}->send_srv_msg ($self->{icl}, "353", join (' ', @part), $self->{icl}->{nickname}, "=", $ic);
194			@part = ();
195			}
196			}
197			if (@part) {
198			$self->{s}->send_srv_msg ($self->{icl}, "353", join (' ', @part), $self->{icl}->{nickname}, "=", $ic);
199			}
200			$self->{s}->send_srv_msg ($self->{icl}, "366", "End of NAMES list", $self->{icl}->{nickname}, $ic);
201			}
202
203			sub join_knuddler {
204			my ($self, $knuddler, $age, $gender, $room) = @_;
205			my $ic = $self->room_to_irc ($room);
206			my $in = $self->knuddler_to_nick ($knuddler);
207
208			my $i = {
209			nickname => $in,
210			knuddelnick => $knuddler,
211			age => $age,
212			gender => $gender
213			};
214
215			$self->{channels}->{lc $ic}->{lc $in}->{info} =
216			$self->{rooms}->{lc $room}->{lc $knuddler}->{info} = $i;
217
218			$self->{s}->send_msg ($self->{icl}, $self->ircpre ($in), "JOIN", $ic);
219			}
220
221			sub part_knuddler {
222			my ($knuddler, $room) = @_;
223			my $ic = $self->room_to_irc ($room);
224			my $in = $self->knuddler_to_nick ($knuddler);
225
226			delete $self->{channels}->{lc $ic}->{lc $in};
227			delete $self->{rooms}->{lc $room}->{lc $knuddler};
228
229			$self->{s}->send_msg ($self->{icl}, $self->ircpre ($in), "PART", "parted nick", $ic);
230			}
231
232			sub handle_room_list {
233			my ($self, $rooms) = @_;
234			$self->room_to_irc ($_) for keys %$rooms;
235			}
236
237			sub change_room {
238			my ($self, $oroom, $nroom) = @_;
239
240			my $oic = $self->room_to_irc ($oroom);
241			my $nic = $self->room_to_irc ($nroom);
242
243			delete $self->{rooms}->{lc $oroom};
244			delete $self->{channels}->{lc $oic};
245
246			delete $self->{myrooms}->{lc $oroom};
247			$self->{myrooms}->{lc $nroom} = 1;
248
249			$self->{s}->send_msg ($self->{icl}, $self->{s}->mk_clpref ($self->{icl}), "PART", "change room", $oic);
250			$self->{s}->send_msg ($self->{icl}, $self->{s}->mk_clpref ($self->{icl}), "JOIN", undef, $nic);
251			}
252
253			sub handle_room_info {
254			my ($self, $room, $ri) = @_;
255
256			$self->{myrooms}->{lc $room} = 1;
257			$self->{s}->send_msg ($self->{icl}, $self->{s}->mk_clpref ($self->{icl}), "JOIN", undef, $self->room_to_irc ($room));
258			}
259
260
261			sub find_any_room {
262			my ($self) = @_;
263
264			return (keys %{$self->{myrooms}})[0];
265			}
266
267			sub send_keepalive_client {
268			my ($self) = @_;
269			my $r = $self->find_any_room ();
270
271			print "KNUDDELS PING\n";
272			return if not defined $r;
273			print "PING TO $f->{knuddelroom} $f->{knuddelnick}\n";
274
275			$self->{c}->send_room_msg ($r, "/knuschel");
276			}
277
278			package main;
279			use strict;
280			use lib '../Net-IRC-Server/';
281			use IO::Select;
282			use Socket;
283			use IO::Socket::INET;
284			use Event;
285			use Net::Knuddels;
286			use Net::IRC::Server;
287			use YAML;
288
289			my %CFG = (
290			server_cl_nick => "_",
291			server_cl_user => "server",
292			server_cl_host => "localhost",
293			server_prefix => "test.de",
294
295			knuddel_nick => "Net-Knuddels",
296			knuddel_pass => "lolfe",
297			knuddel_chan => "Flirt Private",
298			);
299
300			scan_config ();
301
302			my $KDL;
303			my $client;
304			my $ircsrv;
305			my $irc_client;
306
307			sub scan_config {
308			my $config = $ENV{HOME}."/.knuddels2irc2.rc";
309
310			if (! -e $config) { return; }
311
312			my $h = YAML::LoadFile $config;
313
314			if (defined $h and ref $h eq "HASH") {
315			%CFG = (%CFG, %$h);
316			} else {
317			die "$config is not a map!";
318			}
319			}
320
321			sub ready_irc_server {
322			$ircsrv = Net::IRC::Server->new (srv_prefix => $CFG{server_prefix});
323
324			$ircsrv->set_send_cb (sub {
325			my ($cl, $data, @msg) = @_;
326
327			if (not defined $cl->{socket}) {
328			return 1;
329			}
330
331			}, 'PRIVMSG');
332
333			$ircsrv->set_cmd_cb ('*', sub {
334			my $c = uc $_[1]->{command};
335			return 1;
336			}); # default handler ;) Overwrite _anything_ the server does
337
338			$ircsrv->set_cmd_cb ('PING', sub {
339			my ($cl, $msg) = @_;
340			$ircsrv->send_srv_msg ($cl, "PONG", $msg->{params}->[0]);
341			});
342			$ircsrv->set_cmd_cb ('NICK', sub {
343			my ($cl, $msg) = @_;
344			$cl->{nickname} = $msg->{params}[0];
345			});
346
347			$ircsrv->set_cmd_cb ('USER', sub {
348			my ($cl, $msg) = @_;
349			$cl->{username} = $msg->{params}->[0];
350			$cl->{realname} = $msg->{params}->[3];
351
352			$ircsrv->send_srv_msg ($irc_client,
353			"001",
354			"Welcome to NET::IRCServer! "
355			. $ircsrv->mk_clpref ($cl),
356			$cl->{nickname});
357			});
358
359			$ircsrv->set_cmd_cb ('NAMES', sub {
360			my ($cl, $msg) = @_;
361			return if not defined $msg->{params}[0];
362			$KDL->send_nameslist ($msg->{params}[0]);
363			});
364
365			$ircsrv->set_cmd_cb ('PART', sub {
366			my ($cl, $msg) = @_;
367			$KDL->send_exit_room ($msg->{params}[0]);
368			});
369
370			$ircsrv->set_cmd_cb ('JOIN', sub {
371			my ($cl, $msg) = @_;
372			print "ENTER ROOM: $msg->{params}[0]\n";
373			$KDL->send_enter_room ($msg->{params}[0]);
374			});
375
376			$ircsrv->set_cmd_cb ('LIST', sub {
377
378			# for (sort { $a cmp $b } keys %knuddel_channels) {
379			# my $chan = $knuddel_channels{$_};
380			# my $c = room_to_irc ($chan->{name});
381
382			# $ircsrv->send_srv_msg (
383			# $irc_client,
384			# "322",
385			# $chan->{name} . ($chan->{full_flag} ? " (full)" : ""),
386			# $irc_client->{nickname},
387			# "$c",
388			# $chan->{user_count});
389			# }
390			# $ircsrv->send_srv_msg ($irc_client, "323", "End of LIST", $irc_client->{nickname});
391			});
392
393			# $ircsrv->set_cmd_cb ('WHOIS', sub {
394			# my ($cl, $msg) = @_;
395			# my $kcl = $irc_to_knuddel{lc $msg->{params}->[0]};
396			#
397			# $client->send_whois ($kcl->{knuddelroom}, $kcl->{knuddelnick});
398			#
399			# return 1;
400			# });
401
402			$ircsrv->set_cmd_cb ('PRIVMSG', sub {
403			=pod
404			my ($cl, $msg) = @_;
405
406			my $targ = $msg->{params}->[0];
407			my $imsg = scan_msg_nicks $msg->{params}->[1];
408
409			$imsg =~ s/(?<!\\)#/\//;
410			$imsg =~ s/^\\#/#/;
411
412			if (defined $knuddel_channels{lc $targ}) {
413
414			$client->send_room_msg (irc_to_room ($targ), $imsg);
415
416			return 1;
417			} elsif (defined $irc_to_knuddel{lc $targ}) {
418			my $cl = $irc_to_knuddel{lc $targ};
419
420			$client->send_priv_msg ($cl->{knuddelnick}, $cl->{knuddelroom}, $imsg);
421			return 1;
422			}
423			return 0;
424			=cut
425			});
426
427			$ircsrv->set_send_cb (sub {
428			my ($cl, $data) = @_;
429
430			if (defined $cl->{socket}) { # a knuddels-client
431
432			$cl->{socket}->syswrite ($data);
433			print "send $cl->{nickname}> $data"
434			}
435			});
436
437			my $sock = IO::Socket::INET->new(
438			Listen => 5,
439			# LocalAddr => localhost,
440			LocalPort => 6667,
441			Proto => 'tcp',
442			ReuseAddr => 1);
443
444			if (!$sock) { die "Couldn't get listening socket: $!\n" }
445
446			Event->io (
447			fd => $sock,
448			poll => 'r',
449			cb => sub {
450			my $newfh = $sock->accept ();
451			my $addr = $newfh->sockaddr ();
452
453			if (defined $irc_client) {
454			$newfh->close;
455			print "NEWCL\n";
456			return;
457			}
458
459			$irc_client = { hostname => inet_ntoa ($addr), socket => $newfh };
460			$KDL->set_ircclient ($irc_client);
461
462			Event->io (
463			fd => $newfh,
464			poll => 'r',
465			cb => sub {
466			my ($e) = @_;
467
468			my $data;
469			my $c = $newfh->sysread ($data, 2048);
470			print "recv $irc_client->{nickname}> $data";
471
472			if ($c == 0) {
473			$e->w->cancel ();
474			$newfh->close ();
475
476			} else {
477			$ircsrv->feed_irc_data ($irc_client, $data);
478			}
479			});
480			});
481			}
482			sub connect_knuddels {
483			$client->login;
484			Event->io (
485			fd => $client->fh,
486			poll => 'r',
487			cb => sub {
488			my $e = shift;
489
490			if (not $client->ready) {
491			$e->w->cancel;
492			}
493			});
494			}
495
496			####################################################################################
497			########################## MAIN START ##############################################
498			####################################################################################
499
500			$client = new Net::Knuddels::Client PeerAddr => "213.61.5.150:2710";
501			$KDL = new Knuddler c => $client, s => $ircsrv;
502
503
504			$client->register (UNHANDLED => sub {
505			use Dumpvalue;
506			print "---\n";
507			Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
508			});
509
510			$client->register (login => sub {
511			$KDL->activate_client;
512
513			Event->timer (interval => 60, cb => sub {
514			$KDL->send_keepalive_client ();
515			});
516			});
517
518			$client->register (msg_room => sub {
519			my ($room, $user, $msg) = @_;
520			print "($room) =========== $user: $msg\n";
521			$KDL->handle_room_msg ($room, $user, $msg);
522			});
523
524			$client->register (msg_priv => sub {
525			my ($room, $src, $dst, $msg) = @_;
526			print "($room) ########### $src an $dst: $msg\n";
527			$KDL->handle_priv_msg ($room, $src, $dst, $msg);
528			});
529
530			$client->register (join_room => sub {
531			print "$_[1]->{name} joined $_[0]: ".scalar(keys %{$client->{user_lists}->{lc $_[0]}}). " users\n";
532			$KDL->join_knuddler ($_[1]->{name}, $_[1]->{age}, $_[1]->{gender}, $_[0]);
533			});
534
535			$client->register (action_room => sub {
536			$KDL->handle_room_action ($_[0], $_[1]);
537			});
538
539			$client->register (part_room => sub {
540			print "$_[1]->{name} left $_[0]: ".scalar(keys %{$client->{user_lists}->{lc $_[0]}}). " users\n";
541			$KDL->part_knuddler ($_[1]->{name}, $_[0]);
542			});
543
544			$client->register (user_list => sub {
545			my ($room, $list) = @_;
546			print "*** USER JOIN FUER $room ***\n";
547			print scalar (keys %$list)." users\n";
548			print "********************************\n";
549
550			$KDL->handle_userlist ($room);
551			});
552
553			$client->register (room_info => sub {
554			my ($room, $ri) = @_;
555			print "ROOM INFO: $room : $ri->{picture}\n";
556			$KDL->handle_room_info ($room, $ri);
557			});
558
559			$client->register (change_room => sub {
560			my ($r, $nr) = @_;
561			$KDL->change_room ($r, $nr);
562			});
563
564			$client->register (room_list => sub {
565			my ($room_hash) = @_;
566			$KDL->handle_room_list ($room_hash);
567			});
568
569			$client->register (dialog => sub {
570			$KDL->handle_dialog ($_[0]);
571			});
572
573			ready_irc_server;
574			connect_knuddels;
575			Event::loop;
576
577
578