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 hash_pw($$) {
   my ($challenge, $pw) = @_;

   use PApp::Util; warn PApp::Util::dumpval [$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;
   use PApp::Util; warn PApp::Util::dumpval [$xor];

   my ($i, $j);

   --$l;
   use PApp::Util; warn PApp::Util::dumpval [$l];

   if ($l <= 17) {
      for (0 .. $l) {
         $i = $i * 3 + ord substr $xor, $l - $_;
         $j = $j * 5 + ord substr $xor, $_;

         $i = unpack "l", pack "L", (new Math::BigInt $i) & 0xffffffff;
         $j = unpack "l", pack "L", (new Math::BigInt $j) & 0xffffffff;
      }
   } else {
      for ($_ = $l; $_ >= 0; $_ -= int $_/19) {
         $i = $i * 5 + ord substr $xor, $_;
         $j = $j * 3 + ord substr $xor, $l - $_;

         $i = unpack "l", pack "L", (new Math::BigInt $i) & 0xffffffff;
         $j = unpack "l", pack "L", (new Math::BigInt $j) & 0xffffffff;
      }
   }
   warn sprintf "%x %x\n", $i, $j;
   warn sprintf "d%d %d\n", $i, $j;

   $i ^= $j;
   warn sprintf "d%d\n", $i;
   warn sprintf "%x\n", $i;

#   $i = unpack "l", pack "L", (new Math::BigInt +($i & 0xffffff) ^ ($i >> 24)) & 0xffffffff;
#   warn sprintf "%x\n", $i;
#   die $i;

   ($i & 0xffffff) ^ ($i >> 24)
}

warn "hi\n";
#die hash_pw "\300mz\350K\cA\321\cZ \256R", "b"; # 1722400 1a4820

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} = $_[1];
      $self->{login_room}      = $_[2];
      $self->feed_event ("login");
   });

   $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, $type, @arg) = @_;

   for ($type, "ALL") {
      my $ev = $self->{cb}{$_};
      $_->($type, @arg) 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_info>.

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

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

=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->{proto}{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->{proto}{login_challenge}, $password);
}

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

See L<Net::Knuddels::Protocol::register>.

=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.13
Committed:	Thu Jan 13 02:28:42 2005 UTC (19 years, 4 months ago) by root
Branch:	MAIN
Changes since 1.12:	+58 -5 lines
Log Message:	* empty log message *
#	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 hash_pw($$) {
26	my ($challenge, $pw) = @_;
27
28	use PApp::Util; warn PApp::Util::dumpval [$challenge, $pw];
29
30	my $l1 = length $pw;
31	my $l2 = length $challenge;
32
33	my $k = chr ($l1 ^ ($l2 << 4));
34
35	my $l = $l1 < $l2 ? $l2 : $l1;
36
37	my $xor = substr +($pw x 100) ^ ($challenge x 100) ^ ($k x 100), 0, $l;
38	use PApp::Util; warn PApp::Util::dumpval [$xor];
39
40	my ($i, $j);
41
42	--$l;
43	use PApp::Util; warn PApp::Util::dumpval [$l];
44
45	if ($l <= 17) {
46	for (0 .. $l) {
47	$i = $i * 3 + ord substr $xor, $l - $_;
48	$j = $j * 5 + ord substr $xor, $_;
49
50	$i = unpack "l", pack "L", (new Math::BigInt $i) & 0xffffffff;
51	$j = unpack "l", pack "L", (new Math::BigInt $j) & 0xffffffff;
52	}
53	} else {
54	for ($_ = $l; $_ >= 0; $_ -= int $_/19) {
55	$i = $i * 5 + ord substr $xor, $_;
56	$j = $j * 3 + ord substr $xor, $l - $_;
57
58	$i = unpack "l", pack "L", (new Math::BigInt $i) & 0xffffffff;
59	$j = unpack "l", pack "L", (new Math::BigInt $j) & 0xffffffff;
60	}
61	}
62	warn sprintf "%x %x\n", $i, $j;
63	warn sprintf "d%d %d\n", $i, $j;
64
65	$i ^= $j;
66	warn sprintf "d%d\n", $i;
67	warn sprintf "%x\n", $i;
68
69	# $i = unpack "l", pack "L", (new Math::BigInt +($i & 0xffffff) ^ ($i >> 24)) & 0xffffffff;
70	# warn sprintf "%x\n", $i;
71	# die $i;
72
73	($i & 0xffffff) ^ ($i >> 24)
74	}
75
76	warn "hi\n";
77	#die hash_pw "\300mz\350K\cA\321\cZ \256R", "b"; # 1722400 1a4820
78
79	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	$frag = chr unpack "v", pack "b*", $bin =~ /\G.{16}/cg && $1 if $frag eq "\\\\\\";
88	$res .= $frag;
89	}
90	$bin =~ /\G(.[^0].)$/ and die "Net::Knuddels::Receiver: undecodable message tail '$1'";
91
92	$res
93	}
94
95	my %encode = reverse %$Net::Knuddels::Dictionary;
96
97	my $RE_enc = join "\|", map quotemeta, sort { (length $b) <=> (length $a) } keys %encode;
98
99	sub encode($) {
100	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	=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	=over 4
122
123	=cut
124
125	package Net::Knuddels::Protocol;
126
127	=item new
128
129	Create a new C<Net::Knuddels::Protocol> object.
130
131	=cut
132
133	sub new {
134	my $class = shift;
135
136	my %data;
137
138	my $self = bless {
139	@_
140	}, $class;
141
142	$self->register ("(" => sub {
143	$self->{login_challenge} = $_[1];
144	$self->{login_room} = $_[2];
145	$self->feed_event ("login");
146	});
147
148	$self;
149	}
150
151	=item $protocol->feed_data ($octets)
152
153	Feed raw protocol data into the decoder.
154
155	=cut
156
157	sub feed_data($$) {
158	my ($self, $data) = @_;
159
160	# split data stream into packets
161
162	$data = "$self->{rbuf}$data";
163
164	while () {
165	1 <= length $data or last;
166	my $len = ord substr $data, 0, 1;
167
168	my $skip;
169	if ($len & 0x80) {
170	my $tail = (($len >> 5) & 3) - 1;
171	$len = ($len & 0x1f) + 1;
172
173	$tail < length $data or last;
174	$len += (ord substr $data, $_ + 1, 1) << ($_ * 8 + 5)
175	for 0 .. $tail;
176
177	$skip = 2 + $tail;
178	} else {
179	$skip = 1;
180	$len++;
181	}
182
183	$len + $skip <= length $data or last;
184	substr $data, 0, $skip, "";
185	my $msg = substr $data, 0, $len, "";
186
187	$self->feed_msg ($msg);
188	}
189
190	$self->{rbuf} = $data;
191	}
192
193	sub feed_msg($$) {
194	my ($self, $msg) = @_;
195
196	$self->feed_event (split /\0/, Net::Knuddels::decode $msg);
197	}
198
199	sub feed_event($@) {
200	my ($self, $type, @arg) = @_;
201
202	for ($type, "ALL") {
203	my $ev = $self->{cb}{$_};
204	$_->($type, @arg) for values %$ev;
205	}
206	}
207
208	=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	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	}
229
230	=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	the name of a generated event, such as C<login_info>.
235
236	=cut
237
238	sub register {
239	my ($self, $type, $cb) = @_;
240
241	$self->{cb}{$type}{$cb} = $cb;
242	}
243
244	=item $protocol->destroy
245
246	I<MUST> be called to destroy the object, otherwise it will leak (no automatic cleanup).
247
248	=cut
249
250	sub destroy {
251	my ($self) = @_;
252
253	delete $self->{cb};
254	}
255
256	=back
257
258	=head2 CLASS Net::Knuddels::Client
259
260	Implement a Knuddels client connection.
261
262	=over 4
263
264	=cut
265
266	package Net::Knuddels::Client;
267
268	=item new Net::Knuddels::Client [IO::Socket::new arguments]
269
270	Create a new client connection.
271
272	=cut
273
274	use IO::Socket::INET;
275
276	sub new {
277	my ($class, @arg) = @_;
278
279	my $fh = new IO::Socket::INET @arg
280	or Carp::croak "Net::Knuddels::Client::new: $!";
281
282	my $self = bless {
283	fh => $fh,
284	proto => (new Net::Knuddels::Protocol),
285	}, $class;
286
287	syswrite $fh, "\0";
288
289	$self
290	}
291
292	=item $client->fh
293
294	Return the fh used for communications. You are responsible for calling C<<
295	$client->ready >> whenever the fh becomes ready for reading.
296
297	=cut
298
299	sub fh {
300	$_[0]->{fh}
301	}
302
303	=item $client->ready
304
305	To be called then the filehandle is ready for reading. Returns false if
306	the server closed the connection, true otherwise.
307
308	=cut
309
310	sub ready {
311	my ($self) = @_;
312
313	sysread $self->{fh}, my $buf, 8192
314	or return;
315
316	$self->{proto}->feed_data ($buf);
317
318	1;
319	}
320
321	=item $client->command ($type => @args)
322
323	Send a message of type C<$type> and the given arguments to the server.
324
325	=cut
326
327	sub command {
328	my ($self, $type, @args) = @_;
329
330	use Dumpvalue;
331	Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([$type, @args]);
332
333	syswrite $self->{fh}, $self->{proto}->encode_msg ($type, @args);
334	}
335
336	=item $client->login ($url, $unknown)
337
338	Send a 't' message. The default for C<$url> is
339	C<http://www.knuddels.de/applet.html?v=86a&c=0> and C<$unknown> is C<6>.
340
341	=cut
342
343	sub login {
344	my ($self, $url, $unknown) = @_;
345
346	$self->command ("t", "V8.6a", $url \|\| "http://www.knuddels.de/applet.html?v=86a&c=0", $unknown \|\| 3);
347	}
348
349	=item $client->set_nick ($room, $nick, $password)
350
351	Registers the nick with the given password.
352
353	=cut
354
355	sub set_nick {
356	my ($self, $room, $nick, $password) = @_;
357
358	exists $self->{proto}{login_challenge} or Carp::croak "set_nick can only be called after a login event";
359
360	$self->command ("n", $room, $nick, Net::Knuddels::hash_pw $self->{proto}{login_challenge}, $password);
361	}
362
363	=item $client->register ($type => $cb)
364
365	See L<Net::Knuddels::Protocol::register>.
366
367	=cut
368
369	sub register {
370	my ($self, $type, $cb) = @_;
371
372	$self->{proto}->register ($type, $cb);
373	}
374
375	=back
376
377	=head1 AUTHOR
378
379	Marc Lehmann <pcg@goof.com>
380	http://home.schmorp.de/
381
382	=cut
383
384	1;
385