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;
}

=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 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 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 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 (t => sub {
      my $src = $_[0];
      if ($src eq '-') {
        $_[2] = $self->{knuddels_nick} . " " . $_[2];
      } else {
        $_[2] = $src . " " . $_[2];
      }
      $self->{proto}->feed_event (action_room => $self->handle_room ($_[1]), $_[2]);
   });
   $self->register (r => sub {
      my $src = $_[0];
      $src = $self->{knuddels_nick} if $src eq "-";
      $self->{proto}->feed_event (msg_priv => $self->handle_room ($_[2]), $src, $_[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]
      };

      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 (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++;
        }

        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 ($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->{knuddels_nick} = $nick;
   $self->command ("n", $room, $nick, Net::Knuddels::hash_pw $self->{login_challenge}, $password);
}

=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) = @_;

  print "SEND ROOM: $room : $message\n";
  $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) = @_;

  print "SEND ROOM: $room : /p $nick:$message\n";
  $self->command ("e", $room, "/p $nick:$message");
}

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