ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Net-Knuddels/Net/Knuddels.pm
(Generate patch)

Comparing Net-Knuddels/Net/Knuddels.pm (file contents):
Revision 1.15 by elmex, Thu Jan 13 14:52:37 2005 UTC vs.
Revision 1.16 by root, Thu Jan 13 18:50:36 2005 UTC

… …
109=item new 109=item new
110 110
111Create a new C<Net::Knuddels::Protocol> object. 111Create a new C<Net::Knuddels::Protocol> object.
112 112
113=cut 113=cut
114
115sub 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
129Feed raw protocol data into the decoder.
130
131=cut
132
133sub 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
169sub feed_msg($$) {
170 my ($self, $msg) = @_;
171
172 $self->feed_event (split /\0/, Net::Knuddels::decode $msg);
173}
174
175sub 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
192Join the strings with C<\0>, encode the result into a protocol packet and
193return it.
194
195=cut
196
197sub 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
214Register a callback for events of type C<$type>, which is either the name
215of a low-level event sent by the server (such as "k" for dialog box) or
216the name of a generated event, such as C<login>.
217
218=cut
219
220sub register {
221 my ($self, $type, $cb) = @_;
222
223 $self->{cb}{$type}{$cb} = $cb;
224}
225
226=item $protocol->destroy
227
228I<MUST> be called to destroy the object, otherwise it will leak (no automatic cleanup).
229
230=cut
231
232sub destroy {
233 my ($self) = @_;
234
235 delete $self->{cb};
236}
237
238=back
239
240=head2 CLASS Net::Knuddels::Client
241
242Implement a Knuddels client connection.
243
244=over 4
245
246=cut
247
248package Net::Knuddels::Client;
114 249
115sub handle_room { 250sub handle_room {
116 my ($self, $room) = @_; 251 my ($self, $room) = @_;
117 252
118 if ($room eq "-") { 253 if ($room eq "-") {
… …
140 $user->{gender} = 'f'; 275 $user->{gender} = 'f';
141 } 276 }
142 return $user; 277 return $user;
143} 278}
144 279
280=item new Net::Knuddels::Client [IO::Socket::new arguments]
281
282Create a new client connection.
283
284=cut
285
286use IO::Socket::INET;
287
145sub new { 288sub new {
146 my $class = shift; 289 my ($class, @arg) = @_;
147 290
148 my %data; 291 my $fh = new IO::Socket::INET @arg
292 or Carp::croak "Net::Knuddels::Client::new: $!";
149 293
150 my $self = bless { 294 my $self = bless {
151 @_ 295 fh => $fh,
296 proto => (new Net::Knuddels::Protocol),
152 }, $class; 297 }, $class;
298
299 syswrite $fh, "\0";
153 300
154 $self->register ("(" => sub { 301 $self->register ("(" => sub {
155 $self->{login_challenge} = $_[0]; 302 $self->{login_challenge} = $_[0];
156 $self->{login_room} = $_[1]; 303 $self->{login_room} = $_[1];
157 $self->feed_event ("login"); 304 $self->{proto}->feed_event ("login");
158 }); 305 });
159 $self->register (r => sub { 306 $self->register (r => sub {
160 $self->feed_event (msg_priv => $self->handle_room ($_[2]), $_[0], $_[1], $_[3]); 307 $self->{proto}->feed_event (msg_priv => $self->handle_room ($_[2]), $_[0], $_[1], $_[3]);
161 }); 308 });
162 $self->register (e => sub { 309 $self->register (e => sub {
163 $self->feed_event (msg_room => $self->handle_room ($_[1]), $_[0], $_[2]); 310 $self->{proto}->feed_event (msg_room => $self->handle_room ($_[1]), $_[0], $_[2]);
164 }); 311 });
165 $self->register (l => sub { 312 $self->register (l => sub {
166 my $room = $self->handle_room ($_[0]); 313 my $room = $self->handle_room ($_[0]);
167 return if $room eq "-"; # things that shouln't happen 314 return if $room eq "-"; # things that shouln't happen
168 315
… …
175 322
176 $self->calc_user_stats ($user); 323 $self->calc_user_stats ($user);
177 324
178 my $rl = $self->{user_lists}->{lc $room}->{lc $user->{name}} = $user; 325 my $rl = $self->{user_lists}->{lc $room}->{lc $user->{name}} = $user;
179 326
180 $self->feed_event (join_room => $room, $user); 327 $self->{proto}->feed_event (join_room => $room, $user);
181 }); 328 });
182 $self->register (w => sub { 329 $self->register (w => sub {
183 my $room = $self->handle_room ($_[1]); 330 my $room = $self->handle_room ($_[1]);
184 return if $room eq "-"; # things that shouln't happen 331 return if $room eq "-"; # things that shouln't happen
185 332
… …
190 if (not defined $u) { 337 if (not defined $u) {
191 warn "User $username wasn't in room $room, trying to fix... but be careful!!!\n"; 338 warn "User $username wasn't in room $room, trying to fix... but be careful!!!\n";
192 $u = { name => $username }; 339 $u = { name => $username };
193 } 340 }
194 341
195 $self->feed_event (part_room => $room, $u); 342 $self->{proto}->feed_event (part_room => $room, $u);
196 }); 343 });
197 $self->register (a => sub { 344 $self->register (a => sub {
198 # the only_room stuff is from java-code, which has naughy semantics 345 # the only_room stuff is from java-code, which has naughy semantics
199 if (not defined $self->{only_room}) { 346 if (not defined $self->{only_room}) {
200 $self->{only_room} = $_[0]; 347 $self->{only_room} = $_[0];
… …
206 353
207 my $ri = $self->{room}->{lc $_[0]} = { 354 my $ri = $self->{room}->{lc $_[0]} = {
208 picture => $_[7], 355 picture => $_[7],
209 }; 356 };
210 357
211 $self->feed_event (room_info => $_[0], $ri); 358 $self->{proto}->feed_event (room_info => $_[0], $ri);
212 }); 359 });
213 $self->register (u => sub { 360 $self->register (u => sub {
214 my $room = shift; 361 my $room = shift;
215 my $rl = $self->{user_lists}->{lc $room} = {}; 362 my $rl = $self->{user_lists}->{lc $room} = {};
216 my $cur_u = {}; 363 my $cur_u = {};
… …
231 378
232 $self->calc_user_stats ($cur_u); 379 $self->calc_user_stats ($cur_u);
233 $rl->{lc $cur_u->{name}} = $cur_u; 380 $rl->{lc $cur_u->{name}} = $cur_u;
234 $cur_u = {}; 381 $cur_u = {};
235 } 382 }
236 $self->feed_event (user_list => $room, $rl); 383 $self->{proto}->feed_event (user_list => $room, $rl);
237 }); 384 });
238 385
239 $self; 386 $self
240} 387}
241 388
242=item $protocol->feed_data ($octets) 389=item $client->fh
243 390
244Feed raw protocol data into the decoder. 391Return the fh used for communications. You are responsible for calling C<<
392$client->ready >> whenever the fh becomes ready for reading.
245 393
246=cut 394=cut
247 395
248sub feed_data($$) { 396sub fh {
249 my ($self, $data) = @_; 397 $_[0]->{fh}
250
251 # split data stream into packets
252
253 $data = "$self->{rbuf}$data";
254
255 while () {
256 1 <= length $data or last;
257 my $len = ord substr $data, 0, 1;
258
259 my $skip;
260 if ($len & 0x80) {
261 my $tail = (($len >> 5) & 3) - 1;
262 $len = ($len & 0x1f) + 1;
263
264 $tail < length $data or last;
265 $len += (ord substr $data, $_ + 1, 1) << ($_ * 8 + 5)
266 for 0 .. $tail;
267
268 $skip = 2 + $tail;
269 } else {
270 $skip = 1;
271 $len++;
272 }
273
274 $len + $skip <= length $data or last;
275 substr $data, 0, $skip, "";
276 my $msg = substr $data, 0, $len, "";
277
278 $self->feed_msg ($msg);
279 }
280
281 $self->{rbuf} = $data;
282} 398}
283 399
284sub feed_msg($$) { 400=item $client->ready
401
402To be called then the filehandle is ready for reading. Returns false if
403the server closed the connection, true otherwise.
404
405=cut
406
407sub ready {
285 my ($self, $msg) = @_; 408 my ($self) = @_;
286 409
287 $self->feed_event (split /\0/, Net::Knuddels::decode $msg); 410 sysread $self->{fh}, my $buf, 8192
288} 411 or return;
289 412
290sub feed_event($@) { 413 $self->{proto}->feed_data ($buf);
291 my ($self, @cmd) = @_;
292 414
293 my $ev = $self->{cb}{ALL}; 415 1;
294 $_->(@cmd) for values %$ev;
295
296 unless ($self->{cb}{$cmd[0]}) {
297 my $ev = $self->{cb}{UNHANDLED};
298 $_->(@cmd) for values %$ev;
299 }
300
301 my $ev = $self->{cb}{shift @cmd};
302 $_->(@cmd) for values %$ev;
303} 416}
304 417
305=item $msg = $protocol->encode_msg (@strings) 418=item $client->command ($type => @args)
306 419
307Join the strings with C<\0>, encode the result into a protocol packet and 420Send a message of type C<$type> and the given arguments to the server.
308return it.
309 421
310=cut 422=cut
311 423
312sub encode_msg($@) { 424sub command {
313 my ($self, @args) = @_; 425 my ($self, $type, @args) = @_;
314 my $msg = Net::Knuddels::encode join "\0", @args;
315 my $len = (length $msg) - 1;
316 426
317 if ($len < 0x80) { 427 #use Dumpvalue; Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([$type, @args]);
318 (chr $len) . $msg
319 } else {
320 (chr 0x80 | 0x40 | ($len & 0x1f))
321 . (chr +($len >> 5) % 0xff)
322 . (chr +($len >> 13) % 0xff)
323 . $msg
324 }
325}
326 428
429 syswrite $self->{fh}, $self->{proto}->encode_msg ($type, @args);
430}
431
432=item $client->login ($url, $unknown)
433
434Send a 't' message. The default for C<$url> is
435C<http://www.knuddels.de/applet.html?v=86a&c=0> and C<$unknown> is C<6>.
436
437=cut
438
439sub login {
440 my ($self, $url, $unknown) = @_;
441
442 $self->command ("t", "V8.6a", $url || "http://www.knuddels.de/applet.html?v=86a&c=0", $unknown || 3);
443}
444
445=item $client->set_nick ($room, $nick, $password)
446
447Registers the nick with the given password.
448
449=cut
450
451sub set_nick {
452 my ($self, $room, $nick, $password) = @_;
453
454 exists $self->{login_challenge} or Carp::croak "set_nick can only be called after a login event";
455
456 $self->command ("n", $room, $nick, Net::Knuddels::hash_pw $self->{login_challenge}, $password);
457}
458
327=item $protocol->register ($type => $callback) 459=item $client->register ($type => $cb)
328 460
329Register a callback for events of type C<$type>, which is either the name 461See L<Net::Knuddels::Protocol::register>. The following extra events will
330of a low-level event sent by the server (such as "k" for dialog box) or 462be generated by this class:
331the name of a generated event, such as C<login_info>.
332
333The following events will be generated:
334 463
335 login 464 login
336 set_nick can only be called _after_ a login event has occured. 465 set_nick can only be called _after_ a login event has occured.
337 466
338 msg_room => $room, $user, $msg 467 msg_room => $room, $user, $msg
… …
370=cut 499=cut
371 500
372sub register { 501sub register {
373 my ($self, $type, $cb) = @_; 502 my ($self, $type, $cb) = @_;
374 503
375 $self->{cb}{$type}{$cb} = $cb;
376}
377
378=item $protocol->destroy
379
380I<MUST> be called to destroy the object, otherwise it will leak (no automatic cleanup).
381
382=cut
383
384sub destroy {
385 my ($self) = @_;
386
387 delete $self->{cb};
388}
389
390=back
391
392=head2 CLASS Net::Knuddels::Client
393
394Implement a Knuddels client connection.
395
396=over 4
397
398=cut
399
400package Net::Knuddels::Client;
401
402=item new Net::Knuddels::Client [IO::Socket::new arguments]
403
404Create a new client connection.
405
406=cut
407
408use IO::Socket::INET;
409
410sub new {
411 my ($class, @arg) = @_;
412
413 my $fh = new IO::Socket::INET @arg
414 or Carp::croak "Net::Knuddels::Client::new: $!";
415
416 my $self = bless {
417 fh => $fh,
418 proto => (new Net::Knuddels::Protocol),
419 }, $class;
420
421 syswrite $fh, "\0";
422
423 $self
424}
425
426=item $client->fh
427
428Return the fh used for communications. You are responsible for calling C<<
429$client->ready >> whenever the fh becomes ready for reading.
430
431=cut
432
433sub fh {
434 $_[0]->{fh}
435}
436
437=item $client->ready
438
439To be called then the filehandle is ready for reading. Returns false if
440the server closed the connection, true otherwise.
441
442=cut
443
444sub ready {
445 my ($self) = @_;
446
447 sysread $self->{fh}, my $buf, 8192
448 or return;
449
450 $self->{proto}->feed_data ($buf);
451
452 1;
453}
454
455=item $client->command ($type => @args)
456
457Send a message of type C<$type> and the given arguments to the server.
458
459=cut
460
461sub command {
462 my ($self, $type, @args) = @_;
463
464 #use Dumpvalue; Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([$type, @args]);
465
466 syswrite $self->{fh}, $self->{proto}->encode_msg ($type, @args);
467}
468
469=item $client->login ($url, $unknown)
470
471Send a 't' message. The default for C<$url> is
472C<http://www.knuddels.de/applet.html?v=86a&c=0> and C<$unknown> is C<6>.
473
474=cut
475
476sub login {
477 my ($self, $url, $unknown) = @_;
478
479 $self->command ("t", "V8.6a", $url || "http://www.knuddels.de/applet.html?v=86a&c=0", $unknown || 3);
480}
481
482=item $client->set_nick ($room, $nick, $password)
483
484Registers the nick with the given password.
485
486=cut
487
488sub set_nick {
489 my ($self, $room, $nick, $password) = @_;
490
491 exists $self->{proto}{login_challenge} or Carp::croak "set_nick can only be called after a login event";
492
493 $self->command ("n", $room, $nick, Net::Knuddels::hash_pw $self->{proto}{login_challenge}, $password);
494}
495
496=item $client->register ($type => $cb)
497
498See L<Net::Knuddels::Protocol::register>.
499
500=cut
501
502sub register {
503 my ($self, $type, $cb) = @_;
504
505 $self->{proto}->register ($type, $cb); 504 $self->{proto}->register ($type, $cb);
506} 505}
507 506
508=back 507=back
509 508

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines