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.13 by root, Thu Jan 13 02:28:42 2005 UTC vs.
Revision 1.14 by root, Thu Jan 13 03:05:48 2005 UTC

… …
20use utf8; 20use utf8;
21 21
22use Carp; 22use Carp;
23use Math::BigInt; 23use Math::BigInt;
24 24
25sub _to32($) {
26 unpack "l", pack "L", (new Math::BigInt $_[0]) & 0xffffffff
27}
28
25sub hash_pw($$) { 29sub hash_pw($$) {
26 my ($challenge, $pw) = @_; 30 my ($challenge, $pw) = @_;
27 31
28 use PApp::Util; warn PApp::Util::dumpval [$challenge, $pw];
29
30 my $l1 = length $pw; 32 my $l1 = length $pw;
31 my $l2 = length $challenge; 33 my $l2 = length $challenge;
32 34
33 my $k = chr ($l1 ^ ($l2 << 4)); 35 my $k = chr ($l1 ^ ($l2 << 4));
34 36
35 my $l = $l1 < $l2 ? $l2 : $l1; 37 my $l = $l1 < $l2 ? $l2 : $l1;
36 38
37 my $xor = substr +($pw x 100) ^ ($challenge x 100) ^ ($k x 100), 0, $l; 39 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
40 my ($i, $j); 41 my ($i, $j);
41 42
42 --$l; 43 --$l;
43 use PApp::Util; warn PApp::Util::dumpval [$l];
44 44
45 if ($l <= 17) { 45 if ($l <= 17) {
46 for (0 .. $l) { 46 for (0 .. $l) {
47 $i = $i * 3 + ord substr $xor, $l - $_; 47 $i = _to32 $i * 3 + ord substr $xor, $l - $_;
48 $j = $j * 5 + ord substr $xor, $_; 48 $j = _to32 $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 } 49 }
53 } else { 50 } else {
54 for ($_ = $l; $_ >= 0; $_ -= int $_/19) { 51 for ($_ = $l; $_ >= 0; $_ -= int $_/19) {
55 $i = $i * 5 + ord substr $xor, $_; 52 $i = _to32 $i * 5 + ord substr $xor, $_;
56 $j = $j * 3 + ord substr $xor, $l - $_; 53 $j = _to32 $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 } 54 }
61 } 55 }
62 warn sprintf "%x %x\n", $i, $j;
63 warn sprintf "d%d %d\n", $i, $j;
64 56
65 $i ^= $j; 57 $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) 58 _to32 (($i & 0xffffff) ^ ($i >> 24))
74} 59}
75
76warn "hi\n";
77#die hash_pw "\300mz\350K\cA\321\cZ \256R", "b"; # 1722400 1a4820
78 60
79my $RE_dec = join "|", keys %$Net::Knuddels::Dictionary; 61my $RE_dec = join "|", keys %$Net::Knuddels::Dictionary;
80 62
81sub decode { 63sub decode {
82 my $bin = unpack "b*", $_[0]; 64 my $bin = unpack "b*", $_[0];
83 my $res = ""; 65 my $res = "";
84 66
85 while ($bin =~ /\G($RE_dec)/cog) { 67 while ($bin =~ /\G($RE_dec)/cog) {
86 my $frag = $Net::Knuddels::Dictionary->{$1}; 68 my $frag = $Net::Knuddels::Dictionary->{$1};
87 $frag = chr unpack "v", pack "b*", $bin =~ /\G.{16}/cg && $1 if $frag eq "\\\\\\"; 69 $frag = chr unpack "v", pack "b*", $bin =~ /\G(.{16})/cg && $1 if $frag eq "\\\\\\";
88 $res .= $frag; 70 $res .= $frag;
89 } 71 }
90 $bin =~ /\G(.*[^0].*)$/ and die "Net::Knuddels::Receiver: undecodable message tail '$1'"; 72 $bin =~ /\G(.*[^0].*)$/ and die "Net::Knuddels::Receiver: undecodable message tail '$1'";
91 73
92 $res 74 $res
… …
138 my $self = bless { 120 my $self = bless {
139 @_ 121 @_
140 }, $class; 122 }, $class;
141 123
142 $self->register ("(" => sub { 124 $self->register ("(" => sub {
143 $self->{login_challenge} = $_[1]; 125 $self->{login_challenge} = $_[0];
144 $self->{login_room} = $_[2]; 126 $self->{login_room} = $_[1];
145 $self->feed_event ("login"); 127 $self->feed_event ("login");
128 });
129 $self->register (r => sub {
130 # TODO $room eq "-"
131 $self->feed_event (msg_priv => $_[2], $_[0], $_[1], $_[3]);
132 });
133 $self->register (e => sub {
134 # TODO $room eq "-"
135 $self->feed_event (msg_room => $_[1], $_[0], $_[2]);
146 }); 136 });
147 137
148 $self; 138 $self;
149} 139}
150 140
… …
195 185
196 $self->feed_event (split /\0/, Net::Knuddels::decode $msg); 186 $self->feed_event (split /\0/, Net::Knuddels::decode $msg);
197} 187}
198 188
199sub feed_event($@) { 189sub feed_event($@) {
200 my ($self, $type, @arg) = @_; 190 my ($self, @cmd) = @_;
201 191
202 for ($type, "ALL") {
203 my $ev = $self->{cb}{$_}; 192 my $ev = $self->{cb}{ALL};
193 $_->(@cmd) for values %$ev;
194
195 unless ($self->{cb}{$cmd[0]}) {
196 my $ev = $self->{cb}{UNHANDLED};
204 $_->($type, @arg) for values %$ev; 197 $_->(@cmd) for values %$ev;
205 } 198 }
199
200 my $ev = $self->{cb}{shift @cmd};
201 $_->(@cmd) for values %$ev;
206} 202}
207 203
208=item $msg = $protocol->encode_msg (@strings) 204=item $msg = $protocol->encode_msg (@strings)
209 205
210Join the strings with C<\0>, encode the result into a protocol packet and 206Join the strings with C<\0>, encode the result into a protocol packet and
… …
231 227
232Register a callback for events of type C<$type>, which is either the name 228Register a callback for events of type C<$type>, which is either the name
233of a low-level event sent by the server (such as "k" for dialog box) or 229of a low-level event sent by the server (such as "k" for dialog box) or
234the name of a generated event, such as C<login_info>. 230the name of a generated event, such as C<login_info>.
235 231
232The following events will be generated:
233
234 login
235 set_nick can only be called _after_ a login event has occured.
236
237 msg_room => $room, $user, $msg
238 produced when a public message is uttered :)
239
240 msg_room => $room, $src, $dst, $msg
241 personal message from $src to $dst
242
236=cut 243=cut
237 244
238sub register { 245sub register {
239 my ($self, $type, $cb) = @_; 246 my ($self, $type, $cb) = @_;
240 247
… …
325=cut 332=cut
326 333
327sub command { 334sub command {
328 my ($self, $type, @args) = @_; 335 my ($self, $type, @args) = @_;
329 336
330 use Dumpvalue;
331 Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([$type, @args]); 337 #use Dumpvalue; Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([$type, @args]);
332 338
333 syswrite $self->{fh}, $self->{proto}->encode_msg ($type, @args); 339 syswrite $self->{fh}, $self->{proto}->encode_msg ($type, @args);
334} 340}
335 341
336=item $client->login ($url, $unknown) 342=item $client->login ($url, $unknown)

Diff Legend

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