Net-Knuddels/Net/Knuddels.pm

=head1 NAME

Net::Knuddels - www.knuddels.de protocol implementation.

=head1 SYNOPSIS

 use Net::Knuddels;

=head1 DESCRIPTION

RTSL.

=cut

#TODO (Singles 15-17) headbanger16 >> LINK:Net-Knuddels (privat): hä was ins arschloch??

#TODO: PING:
#0  4
#1  "elmecks|1106987572172"

# TODO: anti-idle, immer oder optional

# TODO: send_james for james-messages

# TODO: Es wurde zu h\344ufig ein falsches Passwort beim Login verwendet.
# TODO: _Falsches Passwort_ f\374r ich bin suess verwendet.
# TODO: Dieser Channel ist auf _maximal 50_ Leute beschr\344nkt, bitte w\344hle einen anderen Channel.
# TODO: Sie sind mit ihrem Nick in zuvielen Channels gleichzeitig eingeloggt. Schlie\337en Sie zuerst einen anderen Channel

package Net::Knuddels;

use Net::Knuddels::Dictionary;

use strict;
use utf8;

use Carp;
use Math::BigInt;
use Time::HiRes;

sub _to32($) {
   unpack "l", pack "L", (new Math::BigInt $_[0]) & 0xffffffff
}

sub hash_pw($$) {
   my ($challenge, $pw) = @_;

   my $l1 = length $pw;
   my $l2 = length $challenge;

   my $k = chr ($l1 ^ ($l2 << 4));

   my $l = $l1 < $l2 ? $l2 : $l1;

   my $xor = substr +($pw x 100) ^ ($challenge x 100) ^ ($k x 100), 0, $l;

   my ($i, $j);

   --$l;

   if ($l <= 17) {
      for my $x (0 .. $l) {
         $i = _to32 $i * 3 + ord substr $xor, $l - $x;
         $j = _to32 $j * 5 + ord substr $xor, $x;
      }
   } else {
      for (my $x = $l; $x >= 0; $x -= int +($l+1)/19) {
         $i = _to32 $i * 5 + ord substr $xor, $x;
         $j = _to32 $j * 3 + ord substr $xor, $l - $x;
      }
   }

   $i ^= $j;

   use integer; # force signed shift
   _to32 (($i & 0xffffff) ^ ($i >> 24))
}

my $RE_dec = join "|", keys %$Net::Knuddels::Dictionary;

sub decode {
   my $bin = unpack "b*", $_[0];
   my $res = "";

   while ($bin =~ /\G($RE_dec)/cog) {
      my $frag = $Net::Knuddels::Dictionary->{$1};
      $frag = chr unpack "v", pack "b*", $bin =~ /\G(.{16})/cg && $1 if $frag eq "\\\\\\";
      $res .= $frag;
   }
   $bin =~ /\G(.*[^0].*)$/ and die "Net::Knuddels::Receiver: undecodable message tail '$1'";

   $res
}

my %encode = reverse %$Net::Knuddels::Dictionary;

my $RE_enc = join "|", map quotemeta, sort { (length $b) <=> (length $a) } keys %encode;

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

   my $data = "";

   while () {
      $data .= $encode{$1} while $msg =~ /\G($RE_enc)/cog;

      $msg =~ /\G./csog
         or last;

      $data .= $encode{"\\\\\\"} . unpack "b*", pack "v", ord $1;
   }

   pack "b*", $data
}

=head2 CLASS Net::Knuddels::Protocol

You B<must> call the C<destroy> method of this class when you no longer
use it, as circular references will keep the object alive otherwise.

=over 4

=cut

package Net::Knuddels::Protocol;

=item new

Create a new C<Net::Knuddels::Protocol> object.

=cut

sub new {
   my $class = shift;

   my %data;

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

   $self;
}

=item $protocol->feed_data ($octets)

Feed raw protocol data into the decoder.

=cut

sub feed_data($$) {
   my ($self, $data) = @_;

   # split data stream into packets

   $data = "$self->{rbuf}$data";

   while () {
      1 <= length $data or last;
      my $len = ord substr $data, 0, 1;

      my $skip;
      if ($len & 0x80) {
         my $tail = (($len >> 5) & 3) - 1;
         $len = ($len & 0x1f) + 1;

         $tail < length $data or last;
         $len += (ord substr $data, $_ + 1, 1) << ($_ * 8 + 5)
            for 0 .. $tail;

         $skip = 2 + $tail;
      } else {
         $skip = 1;
         $len++;
      }

      $len + $skip <= length $data or last;
      substr $data, 0, $skip, "";
      my $msg = substr $data, 0, $len, "";

      $self->feed_msg ($msg);
   }

   $self->{rbuf} = $data;
}

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

   $self->feed_event (split /\0/, Net::Knuddels::decode $msg);
}

sub feed_event($@) {
   my ($self, @cmd) = @_;

   my $ev = $self->{cb}{ALL};
   $_->(@cmd) for values %$ev;

   unless ($self->{cb}{$cmd[0]}) {
      my $ev = $self->{cb}{UNHANDLED};
      $_->(@cmd) for values %$ev;
   }

   my $ev = $self->{cb}{shift @cmd};
   $_->(@cmd) for values %$ev;
}

=item $msg = $protocol->encode_msg (@strings)

Join the strings with C<\0>, encode the result into a protocol packet and
return it.

=cut

sub encode_msg($@) {
   my ($self, @args) = @_;
   my $msg = Net::Knuddels::encode join "\0", @args;
   my $len = (length $msg) - 1;

   if ($len < 0x80) {
      (chr $len) . $msg
   } else {
      (chr 0x80 | 0x40 | ($len & 0x1f))
      . (chr +($len >>  5) % 0xff)
      . (chr +($len >> 13) % 0xff)
      . $msg
   }
}

=item $protocol->register ($type => $callback)

Register a callback for events of type C<$type>, which is either the name
of a low-level event sent by the server (such as "k" for dialog box) or
the name of a generated event, such as C<login>.

=cut

sub register {
   my ($self, $type, $cb) = @_;

   $self->{cb}{$type}{$cb} = $cb;
}

=item $protocol->destroy

I<MUST> be called to destroy the object, otherwise it will leak (no automatic cleanup).

=cut

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

   delete $self->{cb};
}

=back

=head2 CLASS Net::Knuddels::Client

Implement a Knuddels client connection.

=over 4

=cut

package Net::Knuddels::Client;

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

  if ($room eq "-") {
    if (scalar (keys %{$self->{room}}) == 1) {
      return (keys %{$self->{room}})[0];
    } else {
      warn "Couldn't assign '-' room to a room!";
      return '#nosuchroom';
    }
  } else {
    return $room;
  }
}

sub update_user_stats {
  my ($user) = @_;

  if ($user->{name} =~ s/\cJ(\d+)$//) {
    $user->{age} = $1 
  }

  if ($user->{picture} =~ m/\bmale/) {
    $user->{gender} = 'm'; 

  } elsif ($user->{picture} =~ m/female/) {
    $user->{gender} = 'f';
  }

  return $user;
}

sub del1 {
  my ($str) = @_;
  my $s = substr ($$str, 0, 1);
  $$str = substr ($$str, 1);
  $s
}

sub del2 {
  my ($str) = @_;
  my $s = substr ($$str, 0, 2);
  $$str = substr ($$str, 2);
  $s
}

sub todelim {
  my ($str) = @_;
  $$str =~ s/^(.*?)\365//;
  $1;
}

sub chk_flag {
  my ($str) = @_;
  if ($$str =~ s/^\343//) {
    return 1;
  } 
  return 0;
}

=item new Net::Knuddels::Client [IO::Socket::new arguments]

Create a new client connection.

Optional extra arguments:

   command_wait => $cb($client,$wait)
      This callback will be called with the client object
      and a time to wait. It must call the C<command_cb> method
      after the time specified, either by a blocking wait
      or via some event loop callback. The default implementation
      just does a blockign wait.

=cut

use IO::Socket::INET;

sub new {
   my ($class, @arg) = @_;

   my $fh = new IO::Socket::INET @arg
     or Carp::croak "Net::Knuddels::Client::new: $!";

   my $self = bless {
      queue => [],
      fh    => $fh,
      proto => (new Net::Knuddels::Protocol),
      rate  => 1, # commands/s
      command_wait => sub {
         select undef, undef, undef, $_[1];
         $_[0]->command_cb;
      },
      queue => [],
      @arg,
   }, $class;

   syswrite $fh, "\0";

   $self->register ("(" => sub {
      $self->{login_challenge} = $_[0];
      $self->{login_room}      = $_[1];
      $self->{proto}->feed_event (login => $_[1]);
   });
   
   $self->register (k => sub {
      my @str = map { s/[\356\343]//; $_ } @_;
      my @out;
      push @out, split /#/, $_ for @str;
      $self->{proto}->feed_event (dialog => \@out);
   });
   
   $self->register (t => sub {
      my $src = $_[0];

      if ($src eq '-') {
        $_[2] = $self->{nick} . " " . $_[2];

      } else {
        $_[2] = $src . " " . $_[2];
      }
      $self->{proto}->feed_event (action_room => $self->handle_room ($_[1]), $_[2]);
   });
   
   my %last_msg; # the last message of a user, to avoid duplicates
   
   $self->register (r => sub {
      my $src = $_[0];
      $src = $self->{nick} if $src eq "-";

      $self->{proto}->feed_event (msg_priv => $self->handle_room ($_[2]), $src, $_[1], $_[3]);

      if ($src eq "James") {
         $self->{proto}->feed_event (msg_priv_james => $self->handle_room ($_[2]), $src, $_[1], $_[3]);
      } elsif ($src eq $self->{nick}) {
         $self->{proto}->feed_event (msg_priv_echo => $self->handle_room ($_[2]), $src, $_[1], $_[3]);
      } else {
         $self->{proto}->feed_event (msg_priv_nondup => $self->handle_room ($_[2]), $src, $_[1], $_[3])
            if $last_msg{$src} ne $_[3];
         $last_msg{$src} = $_[3];
      }
   });

   $self->register (e => sub {
      $self->{proto}->feed_event (msg_room => $self->handle_room ($_[1]), $_[0], $_[2]);
   });
   
   $self->register (l => sub {
      my $room = $self->handle_room ($_[0]);
      return if $room eq "-"; # things that shouln't happen

      my $user = {
        name => $_[1],
        flag => $_[2],
        color => $_[3],
        picture => $_[4]
      };

      update_user_stats ($user);

      my $rl = $self->{user_lists}->{lc $room}->{lc $user->{name}} = $user;
      
      $self->{proto}->feed_event (join_room => $room, $user);
   });

   $self->register (w => sub {
      my $room = $self->handle_room ($_[1]);
      return if $room eq "-"; # things that shouln't happen

      my $username = $_[0];

      my $u = delete $self->{user_lists}->{lc $room}->{lc $username};

      if (not defined $u) {
        warn "User $username wasn't in room $room, trying to fix... but be careful!!!\n";
        $u = { name => $username };
      }

      $self->{proto}->feed_event (part_room => $room, $u);
   });
   
   $self->register (b => sub {
      my @arg = @_;
      my $cc = {};
      $self->{knuddels_rooms}->{$cc->{name}} = {};

      my $last = $cc;
      my $chan_cnt = 2;

      while (@arg) {
        $cc->{name} = shift @arg;

        if ($cc->{name} =~ s/\cJ(\d+)$//) {
          $cc->{user_count} = $1;
        }

        if ($cc->{name} =~ m/^"/) {
          $cc->{name} = "$last->{name} $chan_cnt";
          $chan_cnt++;

        } else {
          $last = $cc;
          $chan_cnt = 2;
        }
 
        $cc->{flag1} = shift @arg;
        $cc->{flag2} = shift @arg;

        my $i = 0;

        for (my $a = shift @arg; $a ne "-"; $a = shift @arg) {

          if ($i == 0) {
            $cc->{picture} = $a;
            $cc->{full_flag} = 1 if $cc->{picture} =~ m/full/i;
          }
          $i++;
        }

        $self->{knuddels_rooms}->{$cc->{name}} = $cc;
        $cc = {};
      }

      $self->{proto}->feed_event (room_list => $self->{knuddels_rooms});
   });

   $self->register (d => sub {
      my $room = $self->handle_room ($_[0]);
      
      delete $self->{room}->{lc $room};
      $self->{room}->{lc $_[1]} = { name => $_[1] };
      
      $self->{proto}->feed_event (change_room => $room, $_[1]);
   });
   
   $self->register ('6' => sub {
      # i have no exact clue what this message does,
      # but java-code seems to say i should do this:
      
      warn "*********************** SIX MESSAGE GOT!!! CHECK PROTOCOL FOR OCCURENCE!!";
      # delete $self->{room}->{lc ($self->handle_room ($_[0]))};
   });

   $self->register (a => sub {
      $self->{my_nick} = $_[1]; # i'm really _not_ shure about this

      my $ri = $self->{room}->{lc $_[0]} = { 
        name => $_[0],
        picture => $_[7],
      };

      $self->{proto}->feed_event (room_info => $_[0], $ri);
   });
   
   $self->register (u => sub {
      my $room = shift;
      my $rl = $self->{user_lists}->{lc $room} = {};
      my $cur_u = {};

      while (@_) {
        $cur_u->{name} = shift;
        $cur_u->{flag} = shift;
        $cur_u->{color} = shift;
        
        my $i = 0;

        while ((my $nxt = shift) ne "-") {
          if ($i == 0) {
            $cur_u->{picture} = $nxt;
          }
          $i++;
        }

        update_user_stats ($cur_u);
        $rl->{lc $cur_u->{name}} = $cur_u;
        $cur_u = {};
      }
      $self->{proto}->feed_event (user_list => $room, $rl);
   });

   $self
}

=item $client->fh

Return the fh used for communications. You are responsible for calling C<<
$client->ready >> whenever the fh becomes ready for reading.

=cut

sub fh {
   $_[0]->{fh}
}

=item $client->ready

To be called then the filehandle is ready for reading. Returns false if
the server closed the connection, true otherwise.

=cut

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

   sysread $self->{fh}, my $buf, 8192
      or return;

   $self->{proto}->feed_data ($buf);

   1;
}

=item $client->command_cb

Should be called by the C<command_wait> callback when the timer has
expired, to send a delayed command to the server.

=cut

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

   while () {
      last unless @{ $self->{queue} };

      my $NOW = Time::HiRes::time;
      my $wait = $self->{next_command} - $NOW;

      if ($wait > 1e-4) {
         $self->{command_wait}->($self, $wait);
         last;
      } else {
         my ($type, @args) = @{ shift @{ $self->{queue} } };
         $self->{next_command} = $NOW + $self->{rate} + 1e-4;

         #use Dumpvalue; Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([$type, @args]);
         syswrite $self->{fh}, $self->{proto}->encode_msg ($type, @args);
      }
   }
}


=item $client->command ($type => @args)

Send a message of type C<$type> and the given arguments to the server,
ensures a proper rate-limit.

=cut

sub command {
   my ($self, $type, @args) = @_;

   if (1 == push @{ $self->{queue} }, [$type, @args]) {
      $self->command_cb;
   }
}

=item $client->login ($url, $unknown)

Send a 't' message. The default for C<$url> is
C<http://www.knuddels.de/applet.html?v=87&c=-3> and C<$unknown> is C<3>.

=cut

sub login {
   my ($self, $url, $unknown) = @_;

   $self->command ("t", "V8.7", $url || "http://www.knuddels.de/applet.html?v=87&c=-3", $unknown || 3);
}

=item $client->enter_room ($room, $nick, $password)

Enters a room C<$room> with C<$nick> and C<$password>. (for joining
multiple rooms call this multiple times)

NOTE: i won't allow joins to multiple rooms with different
nick/password's, the java client reacted very confused.. don't know
whether the server supports this.

=cut

sub enter_room {
   my ($self, $room, $nick, $password) = @_;

   if (defined $self->{nick} and $self->{nick} ne $nick) {
     return # i don't think knuddels-server will be happy if 
            # we join multiple rooms on multiple accounts over 1 connection
   }

   exists $self->{login_challenge} or Carp::croak "set_nick can only be called after a login event";

   $self->{nick} = $nick;
   $self->command ("n", $room, $nick, Net::Knuddels::hash_pw $self->{login_challenge}, $password);
}

=item $client->send_whois ($nick)
 
Sends a whois-request for $nick.

=cut

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

  $self->command ("e", $room, "/w $nick");
}


=item $client->send_room_msg ($nick, $room, $message)
  
Sends a private C<$message> to C<$nick> over C<$room>.

=cut

sub send_room_msg {
  my ($self, $room, $message) = @_;

  $self->command ("e", $room, $message);
}


=item $client->send_priv_msg ($nick, $room, $message)
  
Sends a private C<$message> to C<$nick> over C<$room>.

=cut

sub send_priv_msg {
  my ($self, $nick, $room, $message) = @_;

  $self->command ("e", $room, "/p $nick:$message");
}

=item $client->send_join_room ($oldroom, $room)

Sends the server a join command for C<$room>. This will result in a room
change from C<$oldroom> to C<$room>.

=cut

sub send_join_room {
  my ($self, $old_room, $room) = @_;

  $self->command ("e", $old_room, "/go $room");
}

=item $client->send_exit_room ($room)
  
Exits C<$room> completly. (can be seen as counter method for C<enter_room ()>)

=cut

sub send_exit_room {
  my ($self, $room) = @_;
  $self->command ("w", $room, "\0", "\0");
  delete $self->{room}->{lc $room};
}

=item $client->register ($type => $cb)

See L<Net::Knuddels::Protocol::register>. The following extra events will
be generated by this class:

   login
      set_nick can only be called _after_ a login event has occured.

   msg_room => $room, $user, $msg
      produced when a public message is uttered :)

   msg_priv => $room, $src, $dst, $msg
      personal message from $src to $dst. better use msg_priv_nondup,
      msg_priv_james or msg_priv_echo

   msg_priv_echo => $room, $src, $dst, $msg
      like msg_priv, but only for echoed messages

   msg_priv_james => $room, $src, $dst, $msg
      like msg_priv, but only for messages from James

   msg_priv_nondup => $room, $src, $dst, $msg
      like msg_priv, but avoids duplicate messages, echos and james.

   user_list => $room, $list
      the userlist of a channel named $room, a elmement of the list (a user)
      looks like: 
         {
           name => <name>, 
           flag => <some flag i don't know what it means>, 
           color => like /\d+.\d+.\d+/,
           age   => /\d+/,
           gender => /(f|m)/, 
           picture => <the picture file to put behind the nick> 
         }

   room_info => $room, $room_info
      some information about the $room:
      $room_info =
      {
         picture => <some picturefile>
      }

   join_room => $room, $user
      join message of $user joined the room $room
      $user contains the user structure (see user_list).
      
   part_room => $room, $user
      part message of $user who left the room $room
      $user contains the user structure (see user_list).
=cut

sub register {
   my ($self, $type, $cb) = @_;

   $self->{proto}->register ($type, $cb);
}

=back

=head1 AUTHOR

 Marc Lehmann <pcg@goof.com>
 http://home.schmorp.de/
  
=cut

1;

Revision:	1.34
Committed:	Wed Feb 16 22:17:27 2005 UTC (19 years, 3 months ago) by root
Branch:	MAIN
Changes since 1.33:	+2 -2 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.8	=head1 NAME
2
3			Net::Knuddels - www.knuddels.de protocol implementation.
4
5			=head1 SYNOPSIS
6
7			use Net::Knuddels;
8
9			=head1 DESCRIPTION
10
11			RTSL.
12
13			=cut
14
15	root	1.29	#TODO (Singles 15-17) headbanger16 >> LINK:Net-Knuddels (privat): hä was ins arschloch??
16
17	root	1.31	#TODO: PING:
18	root	1.30	#0 4
19			#1 "elmecks\|1106987572172"
20
21	root	1.31	# TODO: anti-idle, immer oder optional
22
23			# TODO: send_james for james-messages
24
25	root	1.33	# TODO: Es wurde zu h\344ufig ein falsches Passwort beim Login verwendet.
26			# TODO: _Falsches Passwort_ f\374r ich bin suess verwendet.
27			# TODO: Dieser Channel ist auf _maximal 50_ Leute beschr\344nkt, bitte w\344hle einen anderen Channel.
28			# TODO: Sie sind mit ihrem Nick in zuvielen Channels gleichzeitig eingeloggt. Schlie\337en Sie zuerst einen anderen Channel
29
30	root	1.1	package Net::Knuddels;
31
32	root	1.3	use Net::Knuddels::Dictionary;
33
34	root	1.2	use strict;
35			use utf8;
36
37	root	1.4	use Carp;
38			use Math::BigInt;
39	root	1.27	use Time::HiRes;
40	root	1.4
41	root	1.14	sub _to32($) {
42			unpack "l", pack "L", (new Math::BigInt $_[0]) & 0xffffffff
43			}
44
45	root	1.4	sub hash_pw($$) {
46			my ($challenge, $pw) = @_;
47
48			my $l1 = length $pw;
49			my $l2 = length $challenge;
50
51			my $k = chr ($l1 ^ ($l2 << 4));
52
53			my $l = $l1 < $l2 ? $l2 : $l1;
54
55			my $xor = substr +($pw x 100) ^ ($challenge x 100) ^ ($k x 100), 0, $l;
56
57			my ($i, $j);
58
59			--$l;
60
61			if ($l <= 17) {
62	root	1.33	for my $x (0 .. $l) {
63			$i = _to32 $i * 3 + ord substr $xor, $l - $x;
64			$j = _to32 $j * 5 + ord substr $xor, $x;
65	root	1.4	}
66			} else {
67	root	1.33	for (my $x = $l; $x >= 0; $x -= int +($l+1)/19) {
68			$i = _to32 $i * 5 + ord substr $xor, $x;
69			$j = _to32 $j * 3 + ord substr $xor, $l - $x;
70	root	1.4	}
71			}
72
73			$i ^= $j;
74	root	1.33
75			use integer; # force signed shift
76	root	1.14	_to32 (($i & 0xffffff) ^ ($i >> 24))
77	root	1.4	}
78
79	root	1.10	my $RE_dec = join "\|", keys %$Net::Knuddels::Dictionary;
80
81			sub decode {
82			my $bin = unpack "b*", $_[0];
83			my $res = "";
84
85			while ($bin =~ /\G($RE_dec)/cog) {
86			my $frag = $Net::Knuddels::Dictionary->{$1};
87	root	1.14	$frag = chr unpack "v", pack "b*", $bin =~ /\G(.{16})/cg && $1 if $frag eq "\\\\\\";
88	root	1.10	$res .= $frag;
89			}
90			$bin =~ /\G(.[^0].)$/ and die "Net::Knuddels::Receiver: undecodable message tail '$1'";
91
92			$res
93			}
94
95	root	1.9	my %encode = reverse %$Net::Knuddels::Dictionary;
96
97	root	1.10	my $RE_enc = join "\|", map quotemeta, sort { (length $b) <=> (length $a) } keys %encode;
98	root	1.9
99	root	1.10	sub encode($) {
100	root	1.9	my ($msg) = @_;
101
102			my $data = "";
103
104			while () {
105			$data .= $encode{$1} while $msg =~ /\G($RE_enc)/cog;
106
107			$msg =~ /\G./csog
108			or last;
109
110			$data .= $encode{"\\\\\\"} . unpack "b*", pack "v", ord $1;
111			}
112
113			pack "b*", $data
114			}
115
116	root	1.5	=head2 CLASS Net::Knuddels::Protocol
117
118			You B<must> call the C<destroy> method of this class when you no longer
119			use it, as circular references will keep the object alive otherwise.
120
121	root	1.6	=over 4
122
123	root	1.8	=cut
124
125			package Net::Knuddels::Protocol;
126
127	root	1.6	=item new
128
129			Create a new C<Net::Knuddels::Protocol> object.
130
131	root	1.5	=cut
132	root	1.2
133			sub new {
134			my $class = shift;
135
136	root	1.4	my %data;
137
138			my $self = bless {
139			@_
140			}, $class;
141
142			$self;
143	root	1.2	}
144
145	root	1.6	=item $protocol->feed_data ($octets)
146
147			Feed raw protocol data into the decoder.
148
149			=cut
150
151	root	1.2	sub feed_data($$) {
152			my ($self, $data) = @_;
153
154			# split data stream into packets
155
156			$data = "$self->{rbuf}$data";
157
158			while () {
159			1 <= length $data or last;
160			my $len = ord substr $data, 0, 1;
161
162			my $skip;
163			if ($len & 0x80) {
164			my $tail = (($len >> 5) & 3) - 1;
165			$len = ($len & 0x1f) + 1;
166
167			$tail < length $data or last;
168			$len += (ord substr $data, $_ + 1, 1) << ($_ * 8 + 5)
169			for 0 .. $tail;
170
171			$skip = 2 + $tail;
172			} else {
173			$skip = 1;
174			$len++;
175			}
176
177			$len + $skip <= length $data or last;
178			substr $data, 0, $skip, "";
179			my $msg = substr $data, 0, $len, "";
180
181			$self->feed_msg ($msg);
182			}
183
184			$self->{rbuf} = $data;
185			}
186
187			sub feed_msg($$) {
188			my ($self, $msg) = @_;
189	root	1.1
190	root	1.10	$self->feed_event (split /\0/, Net::Knuddels::decode $msg);
191	root	1.1	}
192
193	root	1.2	sub feed_event($@) {
194	root	1.14	my ($self, @cmd) = @_;
195	root	1.1
196	root	1.14	my $ev = $self->{cb}{ALL};
197			$_->(@cmd) for values %$ev;
198
199			unless ($self->{cb}{$cmd[0]}) {
200			my $ev = $self->{cb}{UNHANDLED};
201			$_->(@cmd) for values %$ev;
202	root	1.1	}
203	root	1.14
204			my $ev = $self->{cb}{shift @cmd};
205			$_->(@cmd) for values %$ev;
206	root	1.2	}
207	root	1.1
208	root	1.11	=item $msg = $protocol->encode_msg (@strings)
209
210			Join the strings with C<\0>, encode the result into a protocol packet and
211			return it.
212
213			=cut
214
215			sub encode_msg($@) {
216			my ($self, @args) = @_;
217			my $msg = Net::Knuddels::encode join "\0", @args;
218	root	1.12	my $len = (length $msg) - 1;
219
220			if ($len < 0x80) {
221			(chr $len) . $msg
222			} else {
223			(chr 0x80 \| 0x40 \| ($len & 0x1f))
224			. (chr +($len >> 5) % 0xff)
225			. (chr +($len >> 13) % 0xff)
226			. $msg
227			}
228	root	1.11	}
229
230	root	1.6	=item $protocol->register ($type => $callback)
231
232			Register a callback for events of type C<$type>, which is either the name
233			of a low-level event sent by the server (such as "k" for dialog box) or
234	root	1.16	the name of a generated event, such as C<login>.
235	root	1.6
236			=cut
237
238	root	1.2	sub register {
239			my ($self, $type, $cb) = @_;
240	root	1.1
241	root	1.2	$self->{cb}{$type}{$cb} = $cb;
242	root	1.1	}
243
244	root	1.8	=item $protocol->destroy
245
246	root	1.9	I<MUST> be called to destroy the object, otherwise it will leak (no automatic cleanup).
247	root	1.8
248			=cut
249
250	root	1.5	sub destroy {
251			my ($self) = @_;
252
253			delete $self->{cb};
254			}
255
256	root	1.6	=back
257
258	root	1.8	=head2 CLASS Net::Knuddels::Client
259
260	root	1.9	Implement a Knuddels client connection.
261
262	root	1.8	=over 4
263
264			=cut
265
266			package Net::Knuddels::Client;
267
268	root	1.16	sub handle_room {
269			my ($self, $room) = @_;
270
271			if ($room eq "-") {
272	elmex	1.23	if (scalar (keys %{$self->{room}}) == 1) {
273			return (keys %{$self->{room}})[0];
274	root	1.16	} else {
275			warn "Couldn't assign '-' room to a room!";
276	elmex	1.23	return '#nosuchroom';
277	root	1.16	}
278			} else {
279			return $room;
280			}
281			}
282
283	elmex	1.20	sub update_user_stats {
284			my ($user) = @_;
285	root	1.16
286			if ($user->{name} =~ s/\cJ(\d+)$//) {
287			$user->{age} = $1
288			}
289
290			if ($user->{picture} =~ m/\bmale/) {
291			$user->{gender} = 'm';
292	elmex	1.20
293	root	1.16	} elsif ($user->{picture} =~ m/female/) {
294			$user->{gender} = 'f';
295			}
296	root	1.19
297	root	1.16	return $user;
298			}
299
300	elmex	1.22	sub del1 {
301			my ($str) = @_;
302			my $s = substr ($$str, 0, 1);
303			$$str = substr ($$str, 1);
304			$s
305			}
306
307			sub del2 {
308			my ($str) = @_;
309			my $s = substr ($$str, 0, 2);
310			$$str = substr ($$str, 2);
311			$s
312			}
313
314			sub todelim {
315			my ($str) = @_;
316			$$str =~ s/^(.*?)\365//;
317			$1;
318			}
319
320			sub chk_flag {
321			my ($str) = @_;
322			if ($$str =~ s/^\343//) {
323			return 1;
324			}
325			return 0;
326			}
327
328	root	1.9	=item new Net::Knuddels::Client [IO::Socket::new arguments]
329
330			Create a new client connection.
331
332	root	1.32	Optional extra arguments:
333
334			command_wait => $cb($client,$wait)
335			This callback will be called with the client object
336			and a time to wait. It must call the C<command_cb> method
337			after the time specified, either by a blocking wait
338			or via some event loop callback. The default implementation
339			just does a blockign wait.
340
341	root	1.9	=cut
342
343			use IO::Socket::INET;
344
345			sub new {
346			my ($class, @arg) = @_;
347
348			my $fh = new IO::Socket::INET @arg
349			or Carp::croak "Net::Knuddels::Client::new: $!";
350
351			my $self = bless {
352	root	1.27	queue => [],
353	root	1.9	fh => $fh,
354			proto => (new Net::Knuddels::Protocol),
355	root	1.28	rate => 1, # commands/s
356	root	1.32	command_wait => sub {
357			select undef, undef, undef, $_[1];
358			$_[0]->command_cb;
359			},
360			queue => [],
361	root	1.27	@arg,
362	root	1.9	}, $class;
363
364			syswrite $fh, "\0";
365
366	root	1.16	$self->register ("(" => sub {
367			$self->{login_challenge} = $_[0];
368			$self->{login_room} = $_[1];
369	elmex	1.23	$self->{proto}->feed_event (login => $_[1]);
370	root	1.16	});
371	elmex	1.23
372	elmex	1.22	$self->register (k => sub {
373			my @str = map { s/[\356\343]//; $_ } @_;
374			my @out;
375			push @out, split /#/, $_ for @str;
376			$self->{proto}->feed_event (dialog => \@out);
377			});
378	elmex	1.23
379	elmex	1.21	$self->register (t => sub {
380			my $src = $_[0];
381	elmex	1.23
382	elmex	1.21	if ($src eq '-') {
383	root	1.27	$_[2] = $self->{nick} . " " . $_[2];
384	elmex	1.23
385	elmex	1.21	} else {
386			$_[2] = $src . " " . $_[2];
387			}
388			$self->{proto}->feed_event (action_room => $self->handle_room ($_[1]), $_[2]);
389			});
390	elmex	1.23
391	root	1.27	my %last_msg; # the last message of a user, to avoid duplicates
392
393	root	1.16	$self->register (r => sub {
394	elmex	1.21	my $src = $_[0];
395	root	1.27	$src = $self->{nick} if $src eq "-";
396
397	elmex	1.21	$self->{proto}->feed_event (msg_priv => $self->handle_room ($_[2]), $src, $_[1], $_[3]);
398	root	1.27
399			if ($src eq "James") {
400			$self->{proto}->feed_event (msg_priv_james => $self->handle_room ($_[2]), $src, $_[1], $_[3]);
401			} elsif ($src eq $self->{nick}) {
402			$self->{proto}->feed_event (msg_priv_echo => $self->handle_room ($_[2]), $src, $_[1], $_[3]);
403			} else {
404			$self->{proto}->feed_event (msg_priv_nondup => $self->handle_room ($_[2]), $src, $_[1], $_[3])
405			if $last_msg{$src} ne $_[3];
406			$last_msg{$src} = $_[3];
407			}
408	root	1.16	});
409	root	1.27
410	root	1.16	$self->register (e => sub {
411			$self->{proto}->feed_event (msg_room => $self->handle_room ($_[1]), $_[0], $_[2]);
412			});
413	elmex	1.23
414			$self->register (l => sub {
415	root	1.16	my $room = $self->handle_room ($_[0]);
416			return if $room eq "-"; # things that shouln't happen
417
418			my $user = {
419			name => $_[1],
420			flag => $_[2],
421			color => $_[3],
422			picture => $_[4]
423			};
424
425	elmex	1.20	update_user_stats ($user);
426	root	1.16
427			my $rl = $self->{user_lists}->{lc $room}->{lc $user->{name}} = $user;
428
429			$self->{proto}->feed_event (join_room => $room, $user);
430			});
431	root	1.27
432	root	1.16	$self->register (w => sub {
433			my $room = $self->handle_room ($_[1]);
434			return if $room eq "-"; # things that shouln't happen
435
436			my $username = $_[0];
437
438			my $u = delete $self->{user_lists}->{lc $room}->{lc $username};
439
440			if (not defined $u) {
441			warn "User $username wasn't in room $room, trying to fix... but be careful!!!\n";
442			$u = { name => $username };
443			}
444
445			$self->{proto}->feed_event (part_room => $room, $u);
446			});
447	elmex	1.23
448			$self->register (b => sub {
449			my @arg = @_;
450			my $cc = {};
451			$self->{knuddels_rooms}->{$cc->{name}} = {};
452
453			my $last = $cc;
454			my $chan_cnt = 2;
455
456			while (@arg) {
457			$cc->{name} = shift @arg;
458
459			if ($cc->{name} =~ s/\cJ(\d+)$//) {
460			$cc->{user_count} = $1;
461			}
462	root	1.27
463	elmex	1.23	if ($cc->{name} =~ m/^"/) {
464			$cc->{name} = "$last->{name} $chan_cnt";
465			$chan_cnt++;
466
467			} else {
468			$last = $cc;
469			$chan_cnt = 2;
470			}
471
472			$cc->{flag1} = shift @arg;
473			$cc->{flag2} = shift @arg;
474
475			my $i = 0;
476
477			for (my $a = shift @arg; $a ne "-"; $a = shift @arg) {
478
479			if ($i == 0) {
480			$cc->{picture} = $a;
481			$cc->{full_flag} = 1 if $cc->{picture} =~ m/full/i;
482			}
483			$i++;
484			}
485
486			$self->{knuddels_rooms}->{$cc->{name}} = $cc;
487			$cc = {};
488	root	1.16	}
489
490	elmex	1.23	$self->{proto}->feed_event (room_list => $self->{knuddels_rooms});
491			});
492
493			$self->register (d => sub {
494			my $room = $self->handle_room ($_[0]);
495
496			delete $self->{room}->{lc $room};
497			$self->{room}->{lc $_[1]} = { name => $_[1] };
498
499			$self->{proto}->feed_event (change_room => $room, $_[1]);
500			});
501
502			$self->register ('6' => sub {
503			# i have no exact clue what this message does,
504			# but java-code seems to say i should do this:
505
506			warn "*********************** SIX MESSAGE GOT!!! CHECK PROTOCOL FOR OCCURENCE!!";
507			# delete $self->{room}->{lc ($self->handle_room ($_[0]))};
508			});
509
510			$self->register (a => sub {
511	root	1.16	$self->{my_nick} = $_[1]; # i'm really _not_ shure about this
512
513			my $ri = $self->{room}->{lc $_[0]} = {
514	elmex	1.23	name => $_[0],
515	root	1.16	picture => $_[7],
516			};
517
518			$self->{proto}->feed_event (room_info => $_[0], $ri);
519			});
520	elmex	1.23
521	root	1.16	$self->register (u => sub {
522			my $room = shift;
523			my $rl = $self->{user_lists}->{lc $room} = {};
524			my $cur_u = {};
525
526			while (@_) {
527			$cur_u->{name} = shift;
528			$cur_u->{flag} = shift;
529			$cur_u->{color} = shift;
530
531			my $i = 0;
532
533			while ((my $nxt = shift) ne "-") {
534			if ($i == 0) {
535			$cur_u->{picture} = $nxt;
536			}
537			$i++;
538			}
539
540	elmex	1.20	update_user_stats ($cur_u);
541	root	1.16	$rl->{lc $cur_u->{name}} = $cur_u;
542			$cur_u = {};
543			}
544			$self->{proto}->feed_event (user_list => $room, $rl);
545			});
546
547	root	1.9	$self
548			}
549
550			=item $client->fh
551
552			Return the fh used for communications. You are responsible for calling C<<
553	root	1.13	$client->ready >> whenever the fh becomes ready for reading.
554	root	1.9
555			=cut
556
557			sub fh {
558			$_[0]->{fh}
559			}
560
561	root	1.13	=item $client->ready
562
563			To be called then the filehandle is ready for reading. Returns false if
564			the server closed the connection, true otherwise.
565
566			=cut
567
568			sub ready {
569			my ($self) = @_;
570
571			sysread $self->{fh}, my $buf, 8192
572			or return;
573
574			$self->{proto}->feed_data ($buf);
575
576			1;
577			}
578
579	root	1.32	=item $client->command_cb
580
581			Should be called by the C<command_wait> callback when the timer has
582			expired, to send a delayed command to the server.
583
584			=cut
585
586			sub command_cb {
587			my ($self) = @_;
588
589			while () {
590			last unless @{ $self->{queue} };
591
592			my $NOW = Time::HiRes::time;
593			my $wait = $self->{next_command} - $NOW;
594
595			if ($wait > 1e-4) {
596			$self->{command_wait}->($self, $wait);
597			last;
598			} else {
599			my ($type, @args) = @{ shift @{ $self->{queue} } };
600			$self->{next_command} = $NOW + $self->{rate} + 1e-4;
601
602			#use Dumpvalue; Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([$type, @args]);
603			syswrite $self->{fh}, $self->{proto}->encode_msg ($type, @args);
604			}
605			}
606			}
607
608
609
610	root	1.9	=item $client->command ($type => @args)
611
612	root	1.27	Send a message of type C<$type> and the given arguments to the server,
613			ensures a proper rate-limit.
614	root	1.9
615			=cut
616
617			sub command {
618			my ($self, $type, @args) = @_;
619
620	root	1.32	if (1 == push @{ $self->{queue} }, [$type, @args]) {
621			$self->command_cb;
622			}
623	root	1.9	}
624
625			=item $client->login ($url, $unknown)
626
627			Send a 't' message. The default for C<$url> is
628	root	1.34	C<http://www.knuddels.de/applet.html?v=87&c=-3> and C<$unknown> is C<3>.
629	root	1.9
630			=cut
631
632			sub login {
633	root	1.13	my ($self, $url, $unknown) = @_;
634
635	root	1.34	$self->command ("t", "V8.7", $url \|\| "http://www.knuddels.de/applet.html?v=87&c=-3", $unknown \|\| 3);
636	root	1.13	}
637
638	elmex	1.23	=item $client->enter_room ($room, $nick, $password)
639
640	root	1.27	Enters a room C<$room> with C<$nick> and C<$password>. (for joining
641			multiple rooms call this multiple times)
642	root	1.13
643	root	1.27	NOTE: i won't allow joins to multiple rooms with different
644			nick/password's, the java client reacted very confused.. don't know
645			whether the server supports this.
646	root	1.13
647			=cut
648
649	elmex	1.23	sub enter_room {
650	root	1.13	my ($self, $room, $nick, $password) = @_;
651
652	root	1.27	if (defined $self->{nick} and $self->{nick} ne $nick) {
653	elmex	1.23	return # i don't think knuddels-server will be happy if
654			# we join multiple rooms on multiple accounts over 1 connection
655			}
656
657	root	1.16	exists $self->{login_challenge} or Carp::croak "set_nick can only be called after a login event";
658	root	1.13
659	root	1.27	$self->{nick} = $nick;
660	root	1.16	$self->command ("n", $room, $nick, Net::Knuddels::hash_pw $self->{login_challenge}, $password);
661	root	1.9	}
662
663	elmex	1.22	=item $client->send_whois ($nick)
664
665	root	1.27	Sends a whois-request for $nick.
666	elmex	1.22
667			=cut
668	root	1.27
669	elmex	1.22	sub send_whois {
670			my ($self, $room, $nick) = @_;
671
672			$self->command ("e", $room, "/w $nick");
673			}
674
675
676	elmex	1.21	=item $client->send_room_msg ($nick, $room, $message)
677
678	root	1.27	Sends a private C<$message> to C<$nick> over C<$room>.
679	elmex	1.21
680			=cut
681	root	1.27
682	elmex	1.21	sub send_room_msg {
683			my ($self, $room, $message) = @_;
684
685			$self->command ("e", $room, $message);
686			}
687
688
689			=item $client->send_priv_msg ($nick, $room, $message)
690
691	root	1.27	Sends a private C<$message> to C<$nick> over C<$room>.
692	elmex	1.21
693			=cut
694	root	1.27
695	elmex	1.21	sub send_priv_msg {
696			my ($self, $nick, $room, $message) = @_;
697
698			$self->command ("e", $room, "/p $nick:$message");
699			}
700
701	elmex	1.23	=item $client->send_join_room ($oldroom, $room)
702
703	root	1.27	Sends the server a join command for C<$room>. This will result in a room
704			change from C<$oldroom> to C<$room>.
705	elmex	1.23
706			=cut
707	root	1.27
708	elmex	1.23	sub send_join_room {
709			my ($self, $old_room, $room) = @_;
710
711			$self->command ("e", $old_room, "/go $room");
712			}
713
714			=item $client->send_exit_room ($room)
715
716	root	1.27	Exits C<$room> completly. (can be seen as counter method for C<enter_room ()>)
717	elmex	1.23
718			=cut
719	root	1.27
720	elmex	1.23	sub send_exit_room {
721			my ($self, $room) = @_;
722			$self->command ("w", $room, "\0", "\0");
723			delete $self->{room}->{lc $room};
724			}
725
726	root	1.9	=item $client->register ($type => $cb)
727
728	root	1.16	See L<Net::Knuddels::Protocol::register>. The following extra events will
729			be generated by this class:
730	root	1.9
731	root	1.16	login
732			set_nick can only be called _after_ a login event has occured.
733
734			msg_room => $room, $user, $msg
735			produced when a public message is uttered :)
736
737	root	1.27	msg_priv => $room, $src, $dst, $msg
738			personal message from $src to $dst. better use msg_priv_nondup,
739			msg_priv_james or msg_priv_echo
740
741			msg_priv_echo => $room, $src, $dst, $msg
742			like msg_priv, but only for echoed messages
743
744			msg_priv_james => $room, $src, $dst, $msg
745			like msg_priv, but only for messages from James
746
747			msg_priv_nondup => $room, $src, $dst, $msg
748			like msg_priv, but avoids duplicate messages, echos and james.
749	root	1.16
750			user_list => $room, $list
751			the userlist of a channel named $room, a elmement of the list (a user)
752			looks like:
753			{
754			name => <name>,
755			flag => <some flag i don't know what it means>,
756			color => like /\d+.\d+.\d+/,
757			age => /\d+/,
758			gender => /(f\|m)/,
759			picture => <the picture file to put behind the nick>
760			}
761
762			room_info => $room, $room_info
763			some information about the $room:
764			$room_info =
765			{
766			picture => <some picturefile>
767			}
768
769			join_room => $room, $user
770			join message of $user joined the room $room
771			$user contains the user structure (see user_list).
772
773			part_room => $room, $user
774			part message of $user who left the room $room
775			$user contains the user structure (see user_list).
776	root	1.9	=cut
777
778			sub register {
779			my ($self, $type, $cb) = @_;
780
781	root	1.13	$self->{proto}->register ($type, $cb);
782	root	1.9	}
783
784	root	1.8	=back
785
786			=head1 AUTHOR
787
788			Marc Lehmann <pcg@goof.com>
789			http://home.schmorp.de/
790
791	root	1.6	=cut
792
793	root	1.2	1;
794