| … | |
… | |
| 17 | use KGS::Constants; # REPLACE by parsed file, too |
17 | use KGS::Constants; # REPLACE by parsed file, too |
| 18 | |
18 | |
| 19 | use strict; |
19 | use strict; |
| 20 | |
20 | |
| 21 | our %type; |
21 | our %type; |
| 22 | our %send; |
22 | |
| 23 | our %recv; |
23 | our %dec_send; # decode messages send to server |
|
|
24 | our %enc_send; # encode messages send to server |
|
|
25 | our %dec_recv; # decode messages received from server |
|
|
26 | our %enc_recv; # encode messages received from server |
| 24 | |
27 | |
| 25 | { |
28 | { |
| 26 | |
29 | |
| 27 | my $data; # stores currently processed decoding/encoding packet |
30 | my $data; # stores currently processed decoding/encoding packet |
| 28 | |
31 | |
| … | |
… | |
| 74 | |
77 | |
| 75 | sub dec_CONSTANT { |
78 | sub dec_CONSTANT { |
| 76 | $_[0]; |
79 | $_[0]; |
| 77 | } |
80 | } |
| 78 | |
81 | |
|
|
82 | sub dec_password { |
|
|
83 | dec_U64; |
|
|
84 | } |
|
|
85 | |
| 79 | sub dec_HEX { # for debugging |
86 | sub dec_HEX { # for debugging |
| 80 | "HEX: " . unpack "H*", $data;#d# |
87 | "HEX: " . unpack "H*", $data;#d# |
| 81 | } |
|
|
| 82 | |
|
|
| 83 | sub enc_HEX { |
|
|
| 84 | die "enc_HEX not defined for good"; |
|
|
| 85 | } |
88 | } |
| 86 | |
89 | |
| 87 | ############################################################################# |
90 | ############################################################################# |
| 88 | |
91 | |
| 89 | sub enc_U8 { |
92 | sub enc_U8 { |
| … | |
… | |
| 121 | } |
124 | } |
| 122 | |
125 | |
| 123 | sub enc_STRING { |
126 | sub enc_STRING { |
| 124 | # should use encode for speed and clarity ;) |
127 | # should use encode for speed and clarity ;) |
| 125 | $data .= pack "v*", map ord, split //, $_[0]; |
128 | $data .= pack "v*", map ord, split //, $_[0]; |
|
|
129 | } |
|
|
130 | |
|
|
131 | sub enc_CONSTANT { |
|
|
132 | # nop |
| 126 | } |
133 | } |
| 127 | |
134 | |
| 128 | sub enc_password { |
135 | sub enc_password { |
| 129 | require Math::BigInt; # I insist on 32-bit-perl.. should use C |
136 | require Math::BigInt; # I insist on 32-bit-perl.. should use C |
| 130 | # $hash must be 64 bit |
137 | # $hash must be 64 bit |
| 131 | my $hash = new Math::BigInt; |
138 | my $hash = new Math::BigInt; |
| 132 | $hash = $hash * 1055 + ord for split //, $_[0]; |
139 | $hash = $hash * 1055 + ord for split //, $_[0]; |
| 133 | enc_U64 $hash; |
140 | enc_U64 $hash; |
|
|
141 | } |
|
|
142 | |
|
|
143 | sub enc_HEX { |
|
|
144 | die "enc_HEX not defined for good"; |
| 134 | } |
145 | } |
| 135 | |
146 | |
| 136 | ]]> |
147 | ]]> |
| 137 | |
148 | |
| 138 | ############################################################################# |
149 | ############################################################################# |
| … | |
… | |
| 190 | } elsif ($type == 22) { |
201 | } elsif ($type == 22) { |
| 191 | push @r, [mark => $add, (&dec_U8 ? MARK_SMALL_W : MARK_SMALL_B), dec_U8, dec_U8]; |
202 | push @r, [mark => $add, (&dec_U8 ? MARK_SMALL_W : MARK_SMALL_B), dec_U8, dec_U8]; |
| 192 | |
203 | |
| 193 | } elsif ($type == 21) { |
204 | } elsif ($type == 21) { |
| 194 | push @r, [mark => $add, MARK_CIRCLE, dec_U8, dec_U8]; |
205 | push @r, [mark => $add, MARK_CIRCLE, dec_U8, dec_U8]; |
|
|
206 | |
|
|
207 | } elsif ($type == 20) { |
|
|
208 | push @r, [mark => $add, MARK_SQUARE, dec_U8, dec_U8]; |
|
|
209 | |
|
|
210 | } elsif ($type == 19) { |
|
|
211 | push @r, [mark => $add, MARK_TRIANGLE, dec_U8, dec_U8]; |
|
|
212 | |
|
|
213 | } elsif ($type == 18) { |
|
|
214 | push @r, [mark => $add, MARK_LABEL, dec_U8, dec_U8, dec_STRING]; |
| 195 | |
215 | |
| 196 | } elsif ($type == 17) { |
216 | } elsif ($type == 17) { |
| 197 | push @r, [set_timer => (dec_U8, dec_U32, dec_time)[0,2,1]]; |
217 | push @r, [set_timer => (dec_U8, dec_U32, dec_time)[0,2,1]]; |
| 198 | |
218 | |
| 199 | } elsif ($type == 16) { |
219 | } elsif ($type == 16) { |
| … | |
… | |
| 271 | } |
291 | } |
| 272 | \@r; |
292 | \@r; |
| 273 | } |
293 | } |
| 274 | |
294 | |
| 275 | sub enc_TREE { |
295 | sub enc_TREE { |
|
|
296 | die "tree encoding not yet supported again"; |
| 276 | for (@{$_[0]}) { |
297 | for (@{$_[0]}) { |
| 277 | my ($type, @arg) = @$_; |
298 | my ($type, @arg) = @$_; |
| 278 | |
299 | |
| 279 | if ($type eq "add_child") { |
300 | if ($type eq "add_child") { |
| 280 | enc_U8 255; |
301 | enc_U8 255; |
| … | |
… | |
| 396 | } |
417 | } |
| 397 | </xsl:template> |
418 | </xsl:template> |
| 398 | |
419 | |
| 399 | <xsl:template match="message"> |
420 | <xsl:template match="message"> |
| 400 | # <xsl:value-of select="@name"/> |
421 | # <xsl:value-of select="@name"/> |
| 401 | <xsl:if test="@recv='yes'"> |
422 | $dec_<xsl:value-of select="@dir"/>{0x<xsl:value-of select="@type"/>} = sub { |
| 402 | $recv{0x<xsl:value-of select="@type"/>} = sub { |
|
|
| 403 | $data = $_[0]; |
423 | $data = $_[0]; |
| 404 | my $r; |
424 | my $r; |
| 405 | $r->{type} = "<xsl:value-of select="@name"/>"; |
425 | $r->{type} = "<xsl:value-of select="@name"/>"; |
| 406 | <xsl:apply-templates select="member" mode="dec"/> |
426 | <xsl:apply-templates select="member" mode="dec"/> |
| 407 | $r; |
427 | $r; |
| 408 | }; |
428 | }; |
| 409 | </xsl:if> |
429 | $enc_<xsl:value-of select="@dir"/>{<xsl:value-of select="@name"/>} = sub { |
| 410 | <xsl:if test="@send='yes'"> |
|
|
| 411 | $send{<xsl:value-of select="@name"/>} = sub { |
|
|
| 412 | $data = ""; |
430 | $data = ""; |
| 413 | enc_U16 0x<xsl:value-of select="@type"/>; |
431 | enc_U16 0x<xsl:value-of select="@type"/>; |
| 414 | <xsl:apply-templates select="member" mode="enc"/> |
432 | <xsl:apply-templates select="member" mode="enc"/> |
| 415 | $data; |
433 | $data; |
| 416 | }; |
434 | }; |
| 417 | </xsl:if> |
|
|
| 418 | </xsl:template> |
435 | </xsl:template> |
| 419 | |
436 | |
| 420 | <xsl:template match="member"> |
437 | <xsl:template match="member"> |
| 421 | [<xsl:value-of select="@name"/> |
438 | [<xsl:value-of select="@name"/> |
| 422 | <xsl:text>=> "</xsl:text> |
439 | <xsl:text>=> "</xsl:text> |
