… | |
… | |
12 | |
12 | |
13 | # See doc/protocol.xml and doc/doc2messages.xsl |
13 | # See doc/protocol.xml and doc/doc2messages.xsl |
14 | |
14 | |
15 | package KGS::Messages; |
15 | package KGS::Messages; |
16 | |
16 | |
|
|
17 | use KGS::Constants; # REPLACE by parsed file, too |
|
|
18 | |
17 | use strict; |
19 | use strict; |
18 | |
20 | |
19 | our %type; |
21 | our %type; |
20 | our %send; |
22 | |
21 | our %recv; |
23 | our %dec_client; # decode messages send to server |
|
|
24 | our %enc_client; # encode messages send to server |
|
|
25 | our %dec_server; # decode messages received from server |
|
|
26 | our %enc_server; # encode messages received from server |
22 | |
27 | |
23 | { |
28 | { |
24 | |
29 | |
25 | my $data; # stores currently processed decoding/encoding packet |
30 | my $data; # stores currently processed decoding/encoding packet |
26 | |
31 | |
… | |
… | |
72 | |
77 | |
73 | sub dec_CONSTANT { |
78 | sub dec_CONSTANT { |
74 | $_[0]; |
79 | $_[0]; |
75 | } |
80 | } |
76 | |
81 | |
|
|
82 | sub dec_password { |
|
|
83 | dec_U64; |
|
|
84 | } |
|
|
85 | |
77 | sub dec_HEX { # for debugging |
86 | sub dec_HEX { # for debugging |
78 | "HEX: " . unpack "H*", $data;#d# |
87 | "HEX: " . unpack "H*", $data;#d# |
79 | } |
|
|
80 | |
|
|
81 | sub enc_HEX { |
|
|
82 | die "enc_HEX not defined for good"; |
|
|
83 | } |
88 | } |
84 | |
89 | |
85 | ############################################################################# |
90 | ############################################################################# |
86 | |
91 | |
87 | sub enc_U8 { |
92 | sub enc_U8 { |
… | |
… | |
99 | sub enc_U64 { |
104 | sub enc_U64 { |
100 | enc_U32 $_[0] & 0xffffffff; |
105 | enc_U32 $_[0] & 0xffffffff; |
101 | enc_U32 +($_[0] >> 32) & 0xffffffff; |
106 | enc_U32 +($_[0] >> 32) & 0xffffffff; |
102 | } |
107 | } |
103 | |
108 | |
|
|
109 | sub enc_I8 { |
|
|
110 | $data .= pack "c", $_[0]; |
|
|
111 | } |
|
|
112 | |
|
|
113 | sub enc_I16 { |
|
|
114 | enc_U16 unpack "S", pack "s", $_[0]; |
|
|
115 | } |
|
|
116 | |
104 | sub enc_I32 { |
117 | sub enc_I32 { |
105 | enc_U32 unpack "I", pack "i", $_[0]; |
118 | enc_U32 unpack "I", pack "i", $_[0]; |
106 | } |
119 | } |
107 | |
120 | |
108 | sub enc_DATA { |
121 | sub enc_DATA { |
… | |
… | |
112 | |
125 | |
113 | sub enc_STRING { |
126 | sub enc_STRING { |
114 | # should use encode for speed and clarity ;) |
127 | # should use encode for speed and clarity ;) |
115 | $data .= pack "v*", map ord, split //, $_[0]; |
128 | $data .= pack "v*", map ord, split //, $_[0]; |
116 | } |
129 | } |
|
|
130 | |
|
|
131 | sub enc_CONSTANT { |
|
|
132 | # nop |
|
|
133 | } |
|
|
134 | |
|
|
135 | sub enc_password { |
|
|
136 | require Math::BigInt; # I insist on 32-bit-perl.. should use C |
|
|
137 | # $hash must be 64 bit |
|
|
138 | my $hash = new Math::BigInt; |
|
|
139 | $hash = $hash * 1055 + ord for split //, $_[0]; |
|
|
140 | enc_U64 $hash; |
|
|
141 | } |
|
|
142 | |
|
|
143 | sub enc_HEX { |
|
|
144 | die "enc_HEX not defined for good"; |
|
|
145 | } |
|
|
146 | |
117 | ]]> |
147 | ]]> |
118 | |
148 | |
119 | ############################################################################# |
149 | ############################################################################# |
120 | # types |
150 | # types |
121 | <xsl:apply-templates select="descendant::type"/> |
151 | <xsl:apply-templates select="descendant::type"/> |
… | |
… | |
143 | # this was the most horrible thing to decode. still not everything is decoded correctly(?) |
173 | # this was the most horrible thing to decode. still not everything is decoded correctly(?) |
144 | sub dec_TREE { |
174 | sub dec_TREE { |
145 | my @r; |
175 | my @r; |
146 | while (length $data) { |
176 | while (length $data) { |
147 | my $type = dec_U8; |
177 | my $type = dec_U8; |
|
|
178 | my $add = $type < 128; |
148 | |
179 | |
|
|
180 | $type &= 127; |
|
|
181 | |
149 | if ($type == 255) { |
182 | if ($type == 127) { |
|
|
183 | dec_U8; # unused?? *sigh* |
150 | push @r, [add_child => dec_U32]; |
184 | push @r, [add_node => dec_I32]; |
151 | |
185 | |
|
|
186 | } elsif ($type == 126) { |
|
|
187 | push @r, [set_node => dec_I32]; |
|
|
188 | |
|
|
189 | } elsif ($type == 125) { |
|
|
190 | push @r, [set_current => dec_I32]; |
|
|
191 | |
|
|
192 | } elsif ($type == 34) { |
|
|
193 | push @r, [score => dec_U8, dec_score1000]; |
|
|
194 | |
|
|
195 | } elsif ($type == 29) { |
|
|
196 | push @r, [type_29 => dec_STRING]; |
|
|
197 | warn "TYPE 29 $r[-1][1]\007 PLEASE REPORT";#d# |
|
|
198 | die; |
|
|
199 | |
|
|
200 | } elsif ($type == 28) { |
|
|
201 | # move number, only in variations it seems. oh my. |
|
|
202 | push @r, [movenum => dec_STRING]; |
|
|
203 | |
152 | } elsif ($type == 254) { |
204 | } elsif ($type == 25) { |
153 | push @r, ["done"]; |
205 | push @r, [result => dec_result]; |
154 | |
206 | |
155 | } elsif ($type == 253) { |
207 | } elsif ($type == 23) { |
156 | push @r, ["type253"]; |
208 | push @r, [mark => $add, MARK_GRAYED, dec_U8, dec_U8]; |
157 | # ???? |
|
|
158 | |
209 | |
159 | } elsif ($type == 252) { # even less clear |
210 | } elsif ($type == 22) { |
|
|
211 | push @r, [mark => $add, (&dec_U8 ? MARK_SMALL_W : MARK_SMALL_B), dec_U8, dec_U8]; |
|
|
212 | |
|
|
213 | } elsif ($type == 21) { |
|
|
214 | push @r, [mark => $add, MARK_CIRCLE, dec_U8, dec_U8]; |
|
|
215 | |
|
|
216 | } elsif ($type == 20) { |
|
|
217 | push @r, [mark => $add, MARK_SQUARE, dec_U8, dec_U8]; |
|
|
218 | |
|
|
219 | } elsif ($type == 19) { |
|
|
220 | push @r, [mark => $add, MARK_TRIANGLE, dec_U8, dec_U8]; |
|
|
221 | |
|
|
222 | } elsif ($type == 18) { |
|
|
223 | push @r, [mark => $add, MARK_LABEL, dec_U8, dec_U8, dec_STRING]; |
|
|
224 | |
|
|
225 | } elsif ($type == 17) { |
|
|
226 | push @r, [set_timer => (dec_U8, dec_U32, dec_time)[0,2,1]]; |
|
|
227 | |
|
|
228 | } elsif ($type == 16) { |
|
|
229 | push @r, [set_stone => $add, dec_U8, dec_U8, dec_U8]; |
|
|
230 | |
|
|
231 | } elsif ($type == 14) { |
|
|
232 | push @r, [move => $add, dec_U8, dec_U8, dec_U8]; |
|
|
233 | |
|
|
234 | } elsif (($type >= 4 && $type <= 9) |
|
|
235 | || ($type >= 11 && $type <= 13) |
|
|
236 | || $type == 24) { |
|
|
237 | |
160 | push @r, ["more"]; |
238 | push @r, [({ |
|
|
239 | 4 => "date", |
|
|
240 | 5 => "unknown_comment5", |
|
|
241 | 6 => "unknown_comment6", |
|
|
242 | 7 => "unknown_comment7", |
|
|
243 | 8 => "unknown_comment8", |
|
|
244 | 9 => "copyright", #? |
|
|
245 | 11 => "unknown_comment11", |
|
|
246 | 12 => "unknown_comment12", |
|
|
247 | 13 => "unknown_comment13", |
|
|
248 | 24 => "comment", |
|
|
249 | })->{$type} => dec_STRING]; |
161 | |
250 | |
|
|
251 | } elsif ($type == 3) { |
|
|
252 | push @r, [rank => dec_U8, dec_U32]; |
|
|
253 | |
|
|
254 | } elsif ($type == 2) { |
|
|
255 | push @r, [player => dec_U8, dec_STRING]; |
|
|
256 | |
162 | } elsif ($type == 10) { |
257 | } elsif ($type == 0) { |
163 | # as usual, wms finds yet another way to duplicate code... oh well, what a mess. |
258 | # as usual, wms finds yet another way to duplicate code... oh well, what a mess. |
164 | # (no wonder he is so keen on keeping it secret...) |
259 | # (no wonder he is so keen on keeping it a secret...) |
165 | |
260 | |
166 | push @r, [rules => dec_rules]; |
261 | push @r, [rules => dec_rules]; |
167 | |
262 | |
168 | } elsif ($type == 9 || $type == 22 || $type == 25 || $type == 31 || $type == 32) { |
263 | # OLD |
169 | push @r, [({ |
|
|
170 | 9 => "comment", |
|
|
171 | 22 => "unknown_comment22", |
|
|
172 | 25 => "copyright", #? |
|
|
173 | 31 => "date", |
|
|
174 | 32 => "unknown_comment32", |
|
|
175 | })->{$type} => dec_STRING]; |
|
|
176 | |
264 | |
177 | } elsif ($type == 11 || $type == 12) { |
|
|
178 | push @r, [player => $type - 11, dec_STRING]; |
|
|
179 | |
|
|
180 | } elsif ($type == 13 || $type == 14) { |
|
|
181 | push @r, [rank => $type - 13, dec_U32]; |
|
|
182 | |
|
|
183 | } elsif ($type == 15 || $type == 16) { |
|
|
184 | push @r, [set_timer => $type - 15, dec_time, dec_U16]; |
|
|
185 | |
|
|
186 | } elsif ($type == 17 || $type == 18) { |
|
|
187 | push @r, [score => $type - 17, dec_score]; |
|
|
188 | |
|
|
189 | } elsif ($type == 19) { |
265 | } elsif (1) { |
190 | push @r, [result => dec_result]; |
266 | print STDERR KGS::Listener::Debug::dumpval(\@r); |
|
|
267 | open XTYPE, "|xtype"; print XTYPE $data; close XTYPE; |
|
|
268 | die "unknown tree type $type, PLEASE REPORT and include the game you wanted to watch. thx."; |
191 | |
269 | |
192 | } elsif ($type == 30) { |
270 | } elsif ($type == 30) { |
193 | push @r, [active_player => dec_U8]; |
271 | push @r, [active_player => dec_U8]; |
194 | |
272 | |
195 | } elsif ($type == 0) { # label(?) |
273 | } elsif ($type == 0) { # label(?) |
… | |
… | |
222 | } |
300 | } |
223 | \@r; |
301 | \@r; |
224 | } |
302 | } |
225 | |
303 | |
226 | sub enc_TREE { |
304 | sub enc_TREE { |
|
|
305 | die "tree encoding not yet supported again"; |
227 | for (@{$_[0]}) { |
306 | for (@{$_[0]}) { |
228 | my ($type, @arg) = @$_; |
307 | my ($type, @arg) = @$_; |
229 | |
308 | |
230 | if ($type eq "add_child") { |
309 | if ($type eq "add_child") { |
231 | enc_U8 255; |
310 | enc_U8 255; |
232 | enc_U32 $arg[0]; |
311 | enc_I32 $arg[0]; |
233 | |
312 | |
234 | } elsif ($type eq "done") { |
313 | } elsif ($type eq "done") { |
235 | enc_U8 254; |
314 | enc_U8 254; |
236 | |
315 | |
237 | } elsif ($type eq "more") { |
316 | } elsif ($type eq "more") { |
… | |
… | |
271 | 1; |
350 | 1; |
272 | </xsl:template> |
351 | </xsl:template> |
273 | |
352 | |
274 | <xsl:template match="type[@type = 'S']"> |
353 | <xsl:template match="type[@type = 'S']"> |
275 | sub dec_<xsl:value-of select="@name"/> { |
354 | sub dec_<xsl:value-of select="@name"/> { |
|
|
355 | my $res = ""; |
276 | my @r = unpack "v<xsl:value-of select="@length"/> a*", $data; |
356 | my @r = unpack "v<xsl:value-of select="@length"/> a*", $data; |
277 | $data = pop @r; |
357 | $data = pop @r; |
278 | join ":", map chr, @r; |
358 | for (@r) { |
|
|
359 | last unless $_; |
|
|
360 | $res .= chr $_; |
|
|
361 | } |
|
|
362 | # dump extra data to file for later analysis |
|
|
363 | #my $x = pack "v*", @r; $x =~ s/^(..)*?\x00\x00//s; open DUMP, ">>/tmp/dump"; print DUMP $x; close DUMP;#d# |
|
|
364 | $res; |
279 | } |
365 | } |
280 | |
366 | |
281 | sub enc_<xsl:value-of select="@name"/> { |
367 | sub enc_<xsl:value-of select="@name"/> { |
282 | $data .= pack "v<xsl:value-of select="@length"/>", map ord, split //, $_[0]; |
368 | $data .= pack "v<xsl:value-of select="@length"/>", map ord, split //, $_[0]; |
283 | } |
369 | } |
… | |
… | |
323 | |
409 | |
324 | <xsl:template match="member" mode="enc"> |
410 | <xsl:template match="member" mode="enc"> |
325 | <!-- #d#, remove when kgs is repaired --><xsl:if test="@type = 'username'"> |
411 | <!-- #d#, remove when kgs is repaired --><xsl:if test="@type = 'username'"> |
326 | $_[0]{<xsl:value-of select="@name"/>} =~ /^[A-Za-z][A-Za-z0-9]{0,11}$/ |
412 | $_[0]{<xsl:value-of select="@name"/>} =~ /^[A-Za-z][A-Za-z0-9]{0,11}$/ |
327 | or Carp::confess "FATAL: tried to send illegal username '$_[0]{<xsl:value-of select="@name"/>}'"; |
413 | or Carp::confess "FATAL: tried to send illegal username '$_[0]{<xsl:value-of select="@name"/>}'"; |
328 | </xsl:if><!--#d#--> |
|
|
329 | <!-- #d#, remove when kgs is repaired --><xsl:if test="@name = 'channel'"> |
|
|
330 | $_[0]{<xsl:value-of select="@name"/>} > 0 |
|
|
331 | or Carp::confess "FATAL: tried to send a zero channel id"; |
|
|
332 | </xsl:if><!--#d#--> |
414 | </xsl:if><!--#d#--> |
333 | enc_<xsl:value-of select="@type"/> defined $_[0]{<xsl:value-of select="@name"/>} ? $_[0]{<xsl:value-of select="@name"/> |
415 | enc_<xsl:value-of select="@type"/> defined $_[0]{<xsl:value-of select="@name"/>} ? $_[0]{<xsl:value-of select="@name"/> |
334 | <xsl:text>} : (</xsl:text> |
416 | <xsl:text>} : (</xsl:text> |
335 | <xsl:value-of select="@default"/> |
417 | <xsl:value-of select="@default"/> |
336 | <xsl:text>);</xsl:text> |
418 | <xsl:text>);</xsl:text> |
… | |
… | |
351 | } |
433 | } |
352 | </xsl:template> |
434 | </xsl:template> |
353 | |
435 | |
354 | <xsl:template match="message"> |
436 | <xsl:template match="message"> |
355 | # <xsl:value-of select="@name"/> |
437 | # <xsl:value-of select="@name"/> |
356 | <xsl:if test="@recv='yes'"> |
438 | $dec_<xsl:value-of select="@src"/>{0x<xsl:value-of select="@type"/>} = sub { |
357 | $recv{0x<xsl:value-of select="@type"/>} = sub { |
|
|
358 | $data = $_[0]; |
439 | $data = $_[0]; |
359 | my $r; |
440 | my $r; |
360 | $r->{type} = "<xsl:value-of select="@name"/>"; |
441 | $r->{type} = "<xsl:value-of select="@name"/>"; |
361 | <xsl:apply-templates select="member" mode="dec"/> |
442 | <xsl:apply-templates select="member" mode="dec"/> |
362 | $r; |
443 | $r; |
363 | }; |
444 | }; |
364 | </xsl:if> |
445 | $enc_<xsl:value-of select="@src"/>{<xsl:value-of select="@name"/>} = sub { |
365 | <xsl:if test="@send='yes'"> |
|
|
366 | $send{<xsl:value-of select="@name"/>} = sub { |
|
|
367 | $data = ""; |
446 | $data = ""; |
368 | enc_U16 0x<xsl:value-of select="@type"/>; |
447 | enc_U16 0x<xsl:value-of select="@type"/>; |
369 | <xsl:apply-templates select="member" mode="enc"/> |
448 | <xsl:apply-templates select="member" mode="enc"/> |
370 | $data; |
449 | $data; |
371 | }; |
450 | }; |
372 | </xsl:if> |
|
|
373 | </xsl:template> |
451 | </xsl:template> |
374 | |
452 | |
375 | <xsl:template match="member"> |
453 | <xsl:template match="member"> |
376 | [<xsl:value-of select="@name"/> |
454 | [<xsl:value-of select="@name"/> |
377 | <xsl:text>=> "</xsl:text> |
455 | <xsl:text>=> "</xsl:text> |