Net-Knuddels/Net/Knuddels.pm

=head1 NAME

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

=head1 SYNOPSIS

 use Net::Knuddels;

=head1 DESCRIPTION

RTSL.

=cut

package Net::Knuddels;

use Net::Knuddels::Dictionary;

use strict;
use utf8;

use Carp;
use Math::BigInt;

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 (0 .. $l) {
         $i = _to32 $i * 3 + ord substr $xor, $l - $_;
         $j = _to32 $j * 5 + ord substr $xor, $_;
      }
   } else {
      for ($_ = $l; $_ >= 0; $_ -= int $_/19) {
         $i = _to32 $i * 5 + ord substr $xor, $_;
         $j = _to32 $j * 3 + ord substr $xor, $l - $_;
      }
   }

   $i ^= $j;
   _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->register ("(" => sub {
      $self->{login_challenge} = $_[0];
      $self->{login_room}      = $_[1];
      $self->feed_event ("login");
   });
   $self->register (r => sub {
      $self->feed_event (msg_priv => $self->handle_room ($_[2]), $_[0], $_[1], $_[3]);
   });
   $self->register (e => sub {
      $self->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]
      };

      $self->calc_user_stats ($user);

      my $rl = $self->{user_lists}->{lc $room}->{lc $user->{name}} = $user;
      
      $self->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->feed_event (part_room => $room, $u);
   });
   $self->register (a => sub {
      # the only_room stuff is from java-code, which has naughy semantics
      if (not defined $self->{only_room}) {
        $self->{only_room} = $_[0];
      } else {
        $self->{only_room} = "-";
      }

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

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

      $self->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++;
        }

        $self->calc_user_stats ($cur_u);
        $rl->{lc $cur_u->{name}} = $cur_u;
        $cur_u = {};
      }
      $self->feed_event (user_list => $room, $rl);
   });
   $self->register (k => sub {
     my $windef;
     $windef = join ("\0", @_);
   });

   $self;
}

sub clean_windef {
  my ($self, $windef) = @_;

  my $wd = {};

  if ($windef =~ s/^(.*?)\365//) {
    $wd->{title} = $1;
  }

  while ($windef =~ s/^([^\343])//) {
    if ($1 eq 's') {
      if ($windef =~ s/^(.*?)\365(.*?)\365//) {
        $wd->{cmd} = $1;
        $wd->{nickname} = $2;
      }
    } elsif ($1 eq 'w' or $1 eq 'p') {
      $windef =~ s/^..//;
    } elsif ($1 eq 'h' or $1 eq 'f') {
      $windef =~ s/^.//;
    } elsif ($1 eq 'r') {
       # ... resizeable
    }
  }

  return $wd;
}

=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 (defined $self->{only_room}) {
      return $self->{only_room};
    } else {
      warn "Couldn't assign '-' room to a room!";
      return '-';
    }
  } else {
    return $room;
  }
}

sub calc_user_stats {
  my ($self, $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;
}

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

Create a new client connection.

=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 {
      fh    => $fh,
      proto => (new Net::Knuddels::Protocol),
   }, $class;

   syswrite $fh, "\0";

   $self->register ("(" => sub {
      $self->{login_challenge} = $_[0];
      $self->{login_room}      = $_[1];
      $self->{proto}->feed_event ("login");
   });
   $self->register (r => sub {
      $self->{proto}->feed_event (msg_priv => $self->handle_room ($_[2]), $_[0], $_[1], $_[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]
      };

      $self->calc_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 (a => sub {
      # the only_room stuff is from java-code, which has naughy semantics
      if (not defined $self->{only_room}) {
        $self->{only_room} = $_[0];
      } else {
        $self->{only_room} = "-";
      }

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

      my $ri = $self->{room}->{lc $_[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++;
        }

        $self->calc_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 ($type => @args)

Send a message of type C<$type> and the given arguments to the server.

=cut

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

   #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->login ($url, $unknown)

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

=cut

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

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

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

Registers the nick with the given password.

=cut

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

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

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

=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_room => $room, $src, $dst, $msg
      personal message from $src to $dst

   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.17
Committed:	Thu Jan 13 18:52:37 2005 UTC (21 years, 8 months ago) by elmex
Branch:	MAIN
Changes since 1.16:	+116 -0 lines
Log Message:	some further improvments
#	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.1	package Net::Knuddels;
16
17	root	1.3	use Net::Knuddels::Dictionary;
18
19	root	1.2	use strict;
20			use utf8;
21
22	root	1.4	use Carp;
23			use Math::BigInt;
24
25	root	1.14	sub _to32($) {
26			unpack "l", pack "L", (new Math::BigInt $_[0]) & 0xffffffff
27			}
28
29	root	1.4	sub hash_pw($$) {
30			my ($challenge, $pw) = @_;
31
32			my $l1 = length $pw;
33			my $l2 = length $challenge;
34
35			my $k = chr ($l1 ^ ($l2 << 4));
36
37			my $l = $l1 < $l2 ? $l2 : $l1;
38
39			my $xor = substr +($pw x 100) ^ ($challenge x 100) ^ ($k x 100), 0, $l;
40
41			my ($i, $j);
42
43			--$l;
44
45			if ($l <= 17) {
46			for (0 .. $l) {
47	root	1.14	$i = _to32 $i * 3 + ord substr $xor, $l - $_;
48			$j = _to32 $j * 5 + ord substr $xor, $_;
49	root	1.4	}
50			} else {
51			for ($_ = $l; $_ >= 0; $_ -= int $_/19) {
52	root	1.14	$i = _to32 $i * 5 + ord substr $xor, $_;
53			$j = _to32 $j * 3 + ord substr $xor, $l - $_;
54	root	1.4	}
55			}
56
57			$i ^= $j;
58	root	1.14	_to32 (($i & 0xffffff) ^ ($i >> 24))
59	root	1.4	}
60
61	root	1.10	my $RE_dec = join "\|", keys %$Net::Knuddels::Dictionary;
62
63			sub decode {
64			my $bin = unpack "b*", $_[0];
65			my $res = "";
66
67			while ($bin =~ /\G($RE_dec)/cog) {
68			my $frag = $Net::Knuddels::Dictionary->{$1};
69	root	1.14	$frag = chr unpack "v", pack "b*", $bin =~ /\G(.{16})/cg && $1 if $frag eq "\\\\\\";
70	root	1.10	$res .= $frag;
71			}
72			$bin =~ /\G(.[^0].)$/ and die "Net::Knuddels::Receiver: undecodable message tail '$1'";
73
74			$res
75			}
76
77	root	1.9	my %encode = reverse %$Net::Knuddels::Dictionary;
78
79	root	1.10	my $RE_enc = join "\|", map quotemeta, sort { (length $b) <=> (length $a) } keys %encode;
80	root	1.9
81	root	1.10	sub encode($) {
82	root	1.9	my ($msg) = @_;
83
84			my $data = "";
85
86			while () {
87			$data .= $encode{$1} while $msg =~ /\G($RE_enc)/cog;
88
89			$msg =~ /\G./csog
90			or last;
91
92			$data .= $encode{"\\\\\\"} . unpack "b*", pack "v", ord $1;
93			}
94
95			pack "b*", $data
96			}
97
98	root	1.5	=head2 CLASS Net::Knuddels::Protocol
99
100			You B<must> call the C<destroy> method of this class when you no longer
101			use it, as circular references will keep the object alive otherwise.
102
103	root	1.6	=over 4
104
105	root	1.8	=cut
106
107			package Net::Knuddels::Protocol;
108
109	root	1.6	=item new
110
111			Create a new C<Net::Knuddels::Protocol> object.
112
113	root	1.5	=cut
114	root	1.2
115			sub new {
116			my $class = shift;
117
118	root	1.4	my %data;
119
120			my $self = bless {
121			@_
122			}, $class;
123
124	elmex	1.17	$self->register ("(" => sub {
125			$self->{login_challenge} = $_[0];
126			$self->{login_room} = $_[1];
127			$self->feed_event ("login");
128			});
129			$self->register (r => sub {
130			$self->feed_event (msg_priv => $self->handle_room ($_[2]), $_[0], $_[1], $_[3]);
131			});
132			$self->register (e => sub {
133			$self->feed_event (msg_room => $self->handle_room ($_[1]), $_[0], $_[2]);
134			});
135			$self->register (l => sub {
136			my $room = $self->handle_room ($_[0]);
137			return if $room eq "-"; # things that shouln't happen
138
139			my $user = {
140			name => $_[1],
141			flag => $_[2],
142			color => $_[3],
143			picture => $_[4]
144			};
145
146			$self->calc_user_stats ($user);
147
148			my $rl = $self->{user_lists}->{lc $room}->{lc $user->{name}} = $user;
149
150			$self->feed_event (join_room => $room, $user);
151			});
152			$self->register (w => sub {
153			my $room = $self->handle_room ($_[1]);
154			return if $room eq "-"; # things that shouln't happen
155
156			my $username = $_[0];
157
158			my $u = delete $self->{user_lists}->{lc $room}->{lc $username};
159
160			if (not defined $u) {
161			warn "User $username wasn't in room $room, trying to fix... but be careful!!!\n";
162			$u = { name => $username };
163			}
164
165			$self->feed_event (part_room => $room, $u);
166			});
167			$self->register (a => sub {
168			# the only_room stuff is from java-code, which has naughy semantics
169			if (not defined $self->{only_room}) {
170			$self->{only_room} = $_[0];
171			} else {
172			$self->{only_room} = "-";
173			}
174
175			$self->{my_nick} = $_[1]; # i'm really _not_ shure about this
176
177			my $ri = $self->{room}->{lc $_[0]} = {
178			picture => $_[7],
179			};
180
181			$self->feed_event (room_info => $_[0], $ri);
182			});
183			$self->register (u => sub {
184			my $room = shift;
185			my $rl = $self->{user_lists}->{lc $room} = {};
186			my $cur_u = {};
187
188			while (@_) {
189			$cur_u->{name} = shift;
190			$cur_u->{flag} = shift;
191			$cur_u->{color} = shift;
192
193			my $i = 0;
194
195			while ((my $nxt = shift) ne "-") {
196			if ($i == 0) {
197			$cur_u->{picture} = $nxt;
198			}
199			$i++;
200			}
201
202			$self->calc_user_stats ($cur_u);
203			$rl->{lc $cur_u->{name}} = $cur_u;
204			$cur_u = {};
205			}
206			$self->feed_event (user_list => $room, $rl);
207			});
208			$self->register (k => sub {
209			my $windef;
210			$windef = join ("\0", @_);
211			});
212
213	root	1.4	$self;
214	root	1.2	}
215
216	elmex	1.17	sub clean_windef {
217			my ($self, $windef) = @_;
218
219			my $wd = {};
220
221			if ($windef =~ s/^(.*?)\365//) {
222			$wd->{title} = $1;
223			}
224
225			while ($windef =~ s/^([^\343])//) {
226			if ($1 eq 's') {
227			if ($windef =~ s/^(.?)\365(.?)\365//) {
228			$wd->{cmd} = $1;
229			$wd->{nickname} = $2;
230			}
231			} elsif ($1 eq 'w' or $1 eq 'p') {
232			$windef =~ s/^..//;
233			} elsif ($1 eq 'h' or $1 eq 'f') {
234			$windef =~ s/^.//;
235			} elsif ($1 eq 'r') {
236			# ... resizeable
237			}
238			}
239
240			return $wd;
241			}
242
243	root	1.6	=item $protocol->feed_data ($octets)
244
245			Feed raw protocol data into the decoder.
246
247			=cut
248
249	root	1.2	sub feed_data($$) {
250			my ($self, $data) = @_;
251
252			# split data stream into packets
253
254			$data = "$self->{rbuf}$data";
255
256			while () {
257			1 <= length $data or last;
258			my $len = ord substr $data, 0, 1;
259
260			my $skip;
261			if ($len & 0x80) {
262			my $tail = (($len >> 5) & 3) - 1;
263			$len = ($len & 0x1f) + 1;
264
265			$tail < length $data or last;
266			$len += (ord substr $data, $_ + 1, 1) << ($_ * 8 + 5)
267			for 0 .. $tail;
268
269			$skip = 2 + $tail;
270			} else {
271			$skip = 1;
272			$len++;
273			}
274
275			$len + $skip <= length $data or last;
276			substr $data, 0, $skip, "";
277			my $msg = substr $data, 0, $len, "";
278
279			$self->feed_msg ($msg);
280			}
281
282			$self->{rbuf} = $data;
283			}
284
285			sub feed_msg($$) {
286			my ($self, $msg) = @_;
287	root	1.1
288	root	1.10	$self->feed_event (split /\0/, Net::Knuddels::decode $msg);
289	root	1.1	}
290
291	root	1.2	sub feed_event($@) {
292	root	1.14	my ($self, @cmd) = @_;
293	root	1.1
294	root	1.14	my $ev = $self->{cb}{ALL};
295			$_->(@cmd) for values %$ev;
296
297			unless ($self->{cb}{$cmd[0]}) {
298			my $ev = $self->{cb}{UNHANDLED};
299			$_->(@cmd) for values %$ev;
300	root	1.1	}
301	root	1.14
302			my $ev = $self->{cb}{shift @cmd};
303			$_->(@cmd) for values %$ev;
304	root	1.2	}
305	root	1.1
306	root	1.11	=item $msg = $protocol->encode_msg (@strings)
307
308			Join the strings with C<\0>, encode the result into a protocol packet and
309			return it.
310
311			=cut
312
313			sub encode_msg($@) {
314			my ($self, @args) = @_;
315			my $msg = Net::Knuddels::encode join "\0", @args;
316	root	1.12	my $len = (length $msg) - 1;
317
318			if ($len < 0x80) {
319			(chr $len) . $msg
320			} else {
321			(chr 0x80 \| 0x40 \| ($len & 0x1f))
322			. (chr +($len >> 5) % 0xff)
323			. (chr +($len >> 13) % 0xff)
324			. $msg
325			}
326	root	1.11	}
327
328	root	1.6	=item $protocol->register ($type => $callback)
329
330			Register a callback for events of type C<$type>, which is either the name
331			of a low-level event sent by the server (such as "k" for dialog box) or
332	root	1.16	the name of a generated event, such as C<login>.
333	root	1.6
334			=cut
335
336	root	1.2	sub register {
337			my ($self, $type, $cb) = @_;
338	root	1.1
339	root	1.2	$self->{cb}{$type}{$cb} = $cb;
340	root	1.1	}
341
342	root	1.8	=item $protocol->destroy
343
344	root	1.9	I<MUST> be called to destroy the object, otherwise it will leak (no automatic cleanup).
345	root	1.8
346			=cut
347
348	root	1.5	sub destroy {
349			my ($self) = @_;
350
351			delete $self->{cb};
352			}
353
354	root	1.6	=back
355
356	root	1.8	=head2 CLASS Net::Knuddels::Client
357
358	root	1.9	Implement a Knuddels client connection.
359
360	root	1.8	=over 4
361
362			=cut
363
364			package Net::Knuddels::Client;
365
366	root	1.16	sub handle_room {
367			my ($self, $room) = @_;
368
369			if ($room eq "-") {
370			if (defined $self->{only_room}) {
371			return $self->{only_room};
372			} else {
373			warn "Couldn't assign '-' room to a room!";
374			return '-';
375			}
376			} else {
377			return $room;
378			}
379			}
380
381			sub calc_user_stats {
382			my ($self, $user) = @_;
383
384			if ($user->{name} =~ s/\cJ(\d+)$//) {
385			$user->{age} = $1
386			}
387
388			if ($user->{picture} =~ m/\bmale/) {
389			$user->{gender} = 'm';
390			} elsif ($user->{picture} =~ m/female/) {
391			$user->{gender} = 'f';
392			}
393			return $user;
394			}
395
396	root	1.9	=item new Net::Knuddels::Client [IO::Socket::new arguments]
397
398			Create a new client connection.
399
400			=cut
401
402			use IO::Socket::INET;
403
404			sub new {
405			my ($class, @arg) = @_;
406
407			my $fh = new IO::Socket::INET @arg
408			or Carp::croak "Net::Knuddels::Client::new: $!";
409
410			my $self = bless {
411			fh => $fh,
412			proto => (new Net::Knuddels::Protocol),
413			}, $class;
414
415			syswrite $fh, "\0";
416
417	root	1.16	$self->register ("(" => sub {
418			$self->{login_challenge} = $_[0];
419			$self->{login_room} = $_[1];
420			$self->{proto}->feed_event ("login");
421			});
422			$self->register (r => sub {
423			$self->{proto}->feed_event (msg_priv => $self->handle_room ($_[2]), $_[0], $_[1], $_[3]);
424			});
425			$self->register (e => sub {
426			$self->{proto}->feed_event (msg_room => $self->handle_room ($_[1]), $_[0], $_[2]);
427			});
428			$self->register (l => sub {
429			my $room = $self->handle_room ($_[0]);
430			return if $room eq "-"; # things that shouln't happen
431
432			my $user = {
433			name => $_[1],
434			flag => $_[2],
435			color => $_[3],
436			picture => $_[4]
437			};
438
439			$self->calc_user_stats ($user);
440
441			my $rl = $self->{user_lists}->{lc $room}->{lc $user->{name}} = $user;
442
443			$self->{proto}->feed_event (join_room => $room, $user);
444			});
445			$self->register (w => sub {
446			my $room = $self->handle_room ($_[1]);
447			return if $room eq "-"; # things that shouln't happen
448
449			my $username = $_[0];
450
451			my $u = delete $self->{user_lists}->{lc $room}->{lc $username};
452
453			if (not defined $u) {
454			warn "User $username wasn't in room $room, trying to fix... but be careful!!!\n";
455			$u = { name => $username };
456			}
457
458			$self->{proto}->feed_event (part_room => $room, $u);
459			});
460			$self->register (a => sub {
461			# the only_room stuff is from java-code, which has naughy semantics
462			if (not defined $self->{only_room}) {
463			$self->{only_room} = $_[0];
464			} else {
465			$self->{only_room} = "-";
466			}
467
468			$self->{my_nick} = $_[1]; # i'm really _not_ shure about this
469
470			my $ri = $self->{room}->{lc $_[0]} = {
471			picture => $_[7],
472			};
473
474			$self->{proto}->feed_event (room_info => $_[0], $ri);
475			});
476			$self->register (u => sub {
477			my $room = shift;
478			my $rl = $self->{user_lists}->{lc $room} = {};
479			my $cur_u = {};
480
481			while (@_) {
482			$cur_u->{name} = shift;
483			$cur_u->{flag} = shift;
484			$cur_u->{color} = shift;
485
486			my $i = 0;
487
488			while ((my $nxt = shift) ne "-") {
489			if ($i == 0) {
490			$cur_u->{picture} = $nxt;
491			}
492			$i++;
493			}
494
495			$self->calc_user_stats ($cur_u);
496			$rl->{lc $cur_u->{name}} = $cur_u;
497			$cur_u = {};
498			}
499			$self->{proto}->feed_event (user_list => $room, $rl);
500			});
501
502	root	1.9	$self
503			}
504
505			=item $client->fh
506
507			Return the fh used for communications. You are responsible for calling C<<
508	root	1.13	$client->ready >> whenever the fh becomes ready for reading.
509	root	1.9
510			=cut
511
512			sub fh {
513			$_[0]->{fh}
514			}
515
516	root	1.13	=item $client->ready
517
518			To be called then the filehandle is ready for reading. Returns false if
519			the server closed the connection, true otherwise.
520
521			=cut
522
523			sub ready {
524			my ($self) = @_;
525
526			sysread $self->{fh}, my $buf, 8192
527			or return;
528
529			$self->{proto}->feed_data ($buf);
530
531			1;
532			}
533
534	root	1.9	=item $client->command ($type => @args)
535
536			Send a message of type C<$type> and the given arguments to the server.
537
538			=cut
539
540			sub command {
541			my ($self, $type, @args) = @_;
542
543	root	1.14	#use Dumpvalue; Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([$type, @args]);
544	root	1.13
545			syswrite $self->{fh}, $self->{proto}->encode_msg ($type, @args);
546	root	1.9	}
547
548			=item $client->login ($url, $unknown)
549
550			Send a 't' message. The default for C<$url> is
551			C<http://www.knuddels.de/applet.html?v=86a&c=0> and C<$unknown> is C<6>.
552
553			=cut
554
555			sub login {
556	root	1.13	my ($self, $url, $unknown) = @_;
557
558			$self->command ("t", "V8.6a", $url \|\| "http://www.knuddels.de/applet.html?v=86a&c=0", $unknown \|\| 3);
559			}
560
561			=item $client->set_nick ($room, $nick, $password)
562
563			Registers the nick with the given password.
564
565			=cut
566
567			sub set_nick {
568			my ($self, $room, $nick, $password) = @_;
569
570	root	1.16	exists $self->{login_challenge} or Carp::croak "set_nick can only be called after a login event";
571	root	1.13
572	root	1.16	$self->command ("n", $room, $nick, Net::Knuddels::hash_pw $self->{login_challenge}, $password);
573	root	1.9	}
574
575			=item $client->register ($type => $cb)
576
577	root	1.16	See L<Net::Knuddels::Protocol::register>. The following extra events will
578			be generated by this class:
579	root	1.9
580	root	1.16	login
581			set_nick can only be called _after_ a login event has occured.
582
583			msg_room => $room, $user, $msg
584			produced when a public message is uttered :)
585
586			msg_room => $room, $src, $dst, $msg
587			personal message from $src to $dst
588
589			user_list => $room, $list
590			the userlist of a channel named $room, a elmement of the list (a user)
591			looks like:
592			{
593			name => <name>,
594			flag => <some flag i don't know what it means>,
595			color => like /\d+.\d+.\d+/,
596			age => /\d+/,
597			gender => /(f\|m)/,
598			picture => <the picture file to put behind the nick>
599			}
600
601			room_info => $room, $room_info
602			some information about the $room:
603			$room_info =
604			{
605			picture => <some picturefile>
606			}
607
608			join_room => $room, $user
609			join message of $user joined the room $room
610			$user contains the user structure (see user_list).
611
612			part_room => $room, $user
613			part message of $user who left the room $room
614			$user contains the user structure (see user_list).
615	root	1.9	=cut
616
617			sub register {
618			my ($self, $type, $cb) = @_;
619
620	root	1.13	$self->{proto}->register ($type, $cb);
621	root	1.9	}
622
623	root	1.8	=back
624
625			=head1 AUTHOR
626
627			Marc Lehmann <pcg@goof.com>
628			http://home.schmorp.de/
629
630	root	1.6	=cut
631
632	root	1.2	1;
633