| 1 | package Net::Knuddels; |
1 | package Net::Knuddels; |
| 2 | |
2 | |
|
|
3 | use strict; |
|
|
4 | use utf8; |
|
|
5 | |
| 3 | $dictionary = { |
6 | our $dictionary = { |
| 4 | "00000000" => "icon_fullChannel.gif", |
7 | "00000000" => "icon_fullChannel.gif", |
| 5 | "0000000000" => "", |
8 | "0000000000" => "", |
| 6 | "000000010" => "ar", |
9 | "000000010" => "ar", |
| 7 | "0000000110" => "fe", |
10 | "0000000110" => "fe", |
| 8 | "00000001110" => "En", |
11 | "00000001110" => "En", |
| … | |
… | |
| 2438 | "11111111101" => "un", |
2441 | "11111111101" => "un", |
| 2439 | "11111111110" => "sche", |
2442 | "11111111110" => "sche", |
| 2440 | "11111111111" => "so" |
2443 | "11111111111" => "so" |
| 2441 | }; |
2444 | }; |
| 2442 | |
2445 | |
| 2443 | use utf8; |
2446 | package Net::Knuddels::Receiver; |
| 2444 | |
2447 | |
| 2445 | sub feed { |
2448 | sub new { |
|
|
2449 | my $class = shift; |
|
|
2450 | |
|
|
2451 | bless { @_ }, $class; |
|
|
2452 | } |
|
|
2453 | |
|
|
2454 | sub feed_data($$) { |
|
|
2455 | my ($self, $data) = @_; |
|
|
2456 | |
|
|
2457 | # split data stream into packets |
|
|
2458 | |
|
|
2459 | $data = "$self->{rbuf}$data"; |
|
|
2460 | |
|
|
2461 | while () { |
|
|
2462 | 1 <= length $data or last; |
|
|
2463 | my $len = ord substr $data, 0, 1; |
|
|
2464 | |
|
|
2465 | my $skip; |
|
|
2466 | if ($len & 0x80) { |
|
|
2467 | my $tail = (($len >> 5) & 3) - 1; |
|
|
2468 | $len = ($len & 0x1f) + 1; |
|
|
2469 | |
|
|
2470 | $tail < length $data or last; |
|
|
2471 | $len += (ord substr $data, $_ + 1, 1) << ($_ * 8 + 5) |
|
|
2472 | for 0 .. $tail; |
|
|
2473 | |
|
|
2474 | $skip = 2 + $tail; |
|
|
2475 | } else { |
|
|
2476 | $skip = 1; |
|
|
2477 | $len++; |
|
|
2478 | } |
|
|
2479 | |
|
|
2480 | $len + $skip <= length $data or last; |
|
|
2481 | substr $data, 0, $skip, ""; |
|
|
2482 | my $msg = substr $data, 0, $len, ""; |
|
|
2483 | |
|
|
2484 | $self->feed_msg ($msg); |
|
|
2485 | } |
|
|
2486 | |
|
|
2487 | $self->{rbuf} = $data; |
|
|
2488 | } |
|
|
2489 | |
|
|
2490 | my $RE_dec = join "|", keys %$dictionary; |
|
|
2491 | |
|
|
2492 | sub feed_msg($$) { |
| 2446 | my ($msg) = @_; |
2493 | my ($self, $msg) = @_; |
| 2447 | |
2494 | |
| 2448 | my $bin = unpack "b*", $msg; |
2495 | my $bin = unpack "b*", $msg; |
| 2449 | my $res = ""; |
2496 | my $res = ""; |
| 2450 | |
2497 | |
| 2451 | while (length $bin) { |
2498 | while ($bin =~ /\G($RE_dec)/cmog) { |
| 2452 | my $len = 8; |
2499 | my $frag = $dictionary->{$1}; |
| 2453 | ++$len while !exists $decode{substr $bin, 0, $len} && $len < length $bin; |
|
|
| 2454 | my $frag = $decode{substr $bin, 0, $len, ""} |
|
|
| 2455 | or last; |
|
|
| 2456 | |
|
|
| 2457 | $frag = pack "b*", substr $bin, 0, 16, "" if $frag eq "\\\\\\"; |
2500 | $frag = pack "b*", substr $bin, 0, 16, "" if $frag eq "\\\\\\"; |
| 2458 | $res .= $frag; |
2501 | $res .= $frag; |
| 2459 | } |
2502 | } |
| 2460 | print "$res\n"; |
2503 | $bin =~ /\G(.*[^0].*)$/ and die "Net::Knuddels::Receiver: undecodable message tail '$1'"; |
|
|
2504 | |
|
|
2505 | $self->feed_event (split /\0/, $res); |
| 2461 | } |
2506 | } |
| 2462 | |
2507 | |
| 2463 | binmode STDIN; |
2508 | sub feed_event($@) { |
|
|
2509 | my ($self, $type, @arg) = @_; |
| 2464 | |
2510 | |
| 2465 | local $/; |
2511 | for ($type, "ALL") { |
| 2466 | my $buf = <>; |
2512 | my $ev = $self->{cb}{$_}; |
| 2467 | |
2513 | $_->($type, @arg) for values %$ev; |
| 2468 | for (;;) { |
|
|
| 2469 | my $len = ord substr $buf, 0, 1; |
|
|
| 2470 | my $skip; |
|
|
| 2471 | if ($len & 0x80) { |
|
|
| 2472 | my $tail = (($len >> 5) & 3) - 1; |
|
|
| 2473 | $len = ($len & 0x1f) + 1; |
|
|
| 2474 | $len += (ord substr $buf, $_ + 1, 1) << ($_ * 8 + 5) |
|
|
| 2475 | for 0 .. $tail; |
|
|
| 2476 | $skip = 2 + $tail; |
|
|
| 2477 | } else { |
|
|
| 2478 | $skip = 1; |
|
|
| 2479 | $len++; |
|
|
| 2480 | } |
2514 | } |
| 2481 | |
|
|
| 2482 | $len + $skip <= length $buf or last; |
|
|
| 2483 | substr $buf, 0, $skip, ""; |
|
|
| 2484 | my $msg = substr $buf, 0, $len, ""; |
|
|
| 2485 | |
|
|
| 2486 | feed $msg; |
|
|
| 2487 | } |
2515 | } |
| 2488 | |
2516 | |
|
|
2517 | sub register { |
|
|
2518 | my ($self, $type, $cb) = @_; |
|
|
2519 | |
|
|
2520 | $self->{cb}{$type}{$cb} = $cb; |
|
|
2521 | } |
|
|
2522 | |
|
|
2523 | 1; |
|
|
2524 | |
