ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/kgsueme/doc/doc2perl.xsl
Revision: 1.2
Committed: Fri Jul 25 22:35:50 2003 UTC (20 years, 10 months ago) by pcg
Content type: application/xml
Branch: MAIN
Changes since 1.1: +0 -4 lines
Log Message:
*** empty log message ***

File Contents

# User Rev Content
1 pcg 1.1 <!DOCTYPE xsl:stylesheet>
2     <xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">
3    
4     <xsl:output method="text" media-type="text/plain" encoding="utf-8"/>
5    
6     <xsl:template match="/"><![CDATA[
7     # This is an automatically generated file.
8     # This is an automatically generated file.
9     # This is an automatically generated file.
10     # This is an automatically generated file.
11     # This is an automatically generated file.
12    
13     # See doc/protocol.xml and doc/doc2messages.xsl
14    
15     package KGS::Messages;
16    
17     use KGS::Constants; # REPLACE by parsed file, too
18    
19     use strict;
20    
21     our %type;
22    
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
27    
28     {
29    
30     my $data; # stores currently processed decoding/encoding packet
31    
32     # primitive enc/decoders
33    
34     #############################################################################
35    
36     sub dec_U8 {
37     (my ($r), $data) = unpack "C a*", $data; $r;
38     }
39    
40     sub dec_U16 {
41     (my ($r), $data) = unpack "v a*", $data; $r;
42     }
43    
44     sub dec_U32 {
45     (my ($r), $data) = unpack "V a*", $data; $r;
46     }
47    
48     sub dec_U64 {
49     my ($lo, $hi) = (dec_U32, dec_U32);
50     $lo + $hi * 2**32;
51     }
52    
53     sub dec_I8 {
54     (my ($r), $data) = unpack "c a*", $data;
55     $r;
56     }
57    
58     sub dec_I16 {
59     (my ($r), $data) = unpack "v a*", $data;
60     unpack "s", pack "S", $r;
61     }
62    
63     sub dec_I32 {
64     (my ($r), $data) = unpack "V a*", $data;
65     unpack "i", pack "I", $r;
66     }
67    
68     sub dec_DATA {
69     (my ($r), $data) = ($data, ""); $r;
70     }
71    
72     sub dec_STRING {
73     $data =~ s/^((?:..)*?)(?:\x00\x00|\Z)//s;
74     # use Encode...
75     join "", map chr, unpack "v*", $1;
76     }
77    
78     sub dec_CONSTANT {
79     $_[0];
80     }
81    
82     sub dec_password {
83     dec_U64;
84     }
85    
86     sub dec_HEX { # for debugging
87     "HEX: " . unpack "H*", $data;#d#
88     }
89    
90     #############################################################################
91    
92     sub enc_U8 {
93     $data .= pack "C", $_[0];
94     }
95    
96     sub enc_U16 {
97     $data .= pack "v", $_[0];
98     }
99    
100     sub enc_U32 {
101     $data .= pack "V", $_[0];
102     }
103    
104     sub enc_U64 {
105     enc_U32 $_[0] & 0xffffffff;
106     enc_U32 +($_[0] >> 32) & 0xffffffff;
107     }
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    
117     sub enc_I32 {
118     enc_U32 unpack "I", pack "i", $_[0];
119     }
120    
121     sub enc_DATA {
122     # a dream!
123     $data .= $_[0];
124     }
125    
126     sub enc_STRING {
127     # should use encode for speed and clarity ;)
128     $data .= pack "v*", map ord, split //, $_[0];
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    
147     ]]>
148    
149     #############################################################################
150     # types
151     <xsl:apply-templates select="descendant::type"/>
152    
153     #############################################################################
154     # structures
155     <xsl:apply-templates select="descendant::struct"/>
156    
157     #############################################################################
158     # "less" primitive types<![CDATA[
159    
160     # this was the most horrible thing to decode. still not everything is decoded correctly(?)
161     sub dec_TREE {
162     my @r;
163     while (length $data) {
164     my $type = dec_U8;
165     my $add = $type < 128;
166    
167     $type &= 127;
168    
169     if ($type == 127) {
170     dec_U8; # unused?? *sigh*
171     push @r, [add_node => dec_I32];
172    
173     } elsif ($type == 126) {
174     push @r, [set_node => dec_I32];
175    
176     } elsif ($type == 125) {
177     push @r, [set_current => dec_I32];
178    
179     } elsif ($type == 34) {
180     push @r, [score => dec_U8, dec_score1000];
181    
182     } elsif ($type == 29) {
183     push @r, [type_29 => dec_STRING];
184     warn "TYPE 29 $r[-1][1]\007 PLEASE REPORT";#d#
185     die;
186    
187     } elsif ($type == 28) {
188     # move number, only in variations it seems. oh my.
189     push @r, [movenum => dec_STRING];
190    
191     } elsif ($type == 25) {
192     push @r, [result => dec_result];
193    
194     } elsif ($type == 23) {
195     push @r, [mark => $add, MARK_GRAYED, dec_U8, dec_U8];
196    
197     } elsif ($type == 22) {
198     push @r, [mark => $add, (&dec_U8 ? MARK_SMALL_W : MARK_SMALL_B), dec_U8, dec_U8];
199    
200     } elsif ($type == 21) {
201     push @r, [mark => $add, MARK_CIRCLE, dec_U8, dec_U8];
202    
203     } elsif ($type == 20) {
204     push @r, [mark => $add, MARK_SQUARE, dec_U8, dec_U8];
205    
206     } elsif ($type == 19) {
207     push @r, [mark => $add, MARK_TRIANGLE, dec_U8, dec_U8];
208    
209     } elsif ($type == 18) {
210     push @r, [mark => $add, MARK_LABEL, dec_U8, dec_U8, dec_STRING];
211    
212     } elsif ($type == 17) {
213     push @r, [set_timer => (dec_U8, dec_U32, dec_time)[0,2,1]];
214    
215     } elsif ($type == 16) {
216     push @r, [set_stone => $add, dec_U8, dec_U8, dec_U8];
217    
218     } elsif ($type == 14) {
219     push @r, [move => $add, dec_U8, dec_U8, dec_U8];
220    
221     } elsif (($type >= 4 && $type <= 9)
222     || ($type >= 11 && $type <= 13)
223     || $type == 24) {
224    
225     push @r, [({
226     4 => "date",
227     5 => "unknown_comment5",
228     6 => "unknown_comment6",
229     7 => "unknown_comment7",
230     8 => "unknown_comment8",
231     9 => "copyright", #?
232     11 => "unknown_comment11",
233     12 => "unknown_comment12",
234     13 => "unknown_comment13",
235     24 => "comment",
236     })->{$type} => dec_STRING];
237    
238     } elsif ($type == 3) {
239     push @r, [rank => dec_U8, dec_U32];
240    
241     } elsif ($type == 2) {
242     push @r, [player => dec_U8, dec_STRING];
243    
244     } elsif ($type == 0) {
245     # as usual, wms finds yet another way to duplicate code... oh well, what a mess.
246     # (no wonder he is so keen on keeping it a secret...)
247    
248     push @r, [rules => dec_rules];
249    
250     # OLD
251    
252     } else {
253     print STDERR KGS::Listener::Debug::dumpval(\@r);
254     open XTYPE, "|xtype"; print XTYPE $data; close XTYPE;
255     die "unknown tree type $type, PLEASE REPORT and include the game you wanted to watch. thx.";
256    
257     }
258     }
259     \@r;
260     }
261    
262     sub enc_TREE {
263     for (@{$_[0]}) {
264     my ($type, @arg) = @$_;
265    
266     if ($type eq "add_node") {
267     enc_U8 127;
268     enc_U8 0; # unused?
269     enc_I32 $arg[0];
270    
271     } elsif ($type eq "set_node") {
272     enc_U8 126;
273     enc_I32 $arg[0];
274    
275     } elsif ($type eq "set_current") {
276     enc_U8 125;
277     enc_I32 $arg[0];
278    
279     } elsif ($type eq "movenum") {
280     enc_U8 28;
281     enc_STRING $arg[0];
282    
283     } elsif ($type eq "set_stone") {
284     enc_U8 16 + ($arg[0] && 128);
285     enc_U8 $arg[1];
286     enc_U8 $arg[2];
287     enc_U8 $arg[3];
288    
289     } elsif ($type eq "move") {
290     enc_U8 14 + ($arg[0] && 128);
291     enc_U8 $arg[1];
292     enc_U8 $arg[2];
293     enc_U8 $arg[3];
294    
295     } elsif ($type eq "comment") {
296     enc_U8 24;
297     enc_STRING $arg[0];
298    
299     } else {
300     warn "unable to encode tree node type $type\n";
301     }
302     }
303     }
304     ]]>
305    
306     #############################################################################
307     # messages
308     <xsl:apply-templates select="descendant::message"/>
309     }
310    
311     1;
312     </xsl:template>
313    
314     <xsl:template match="type[@type = 'S']">
315     sub dec_<xsl:value-of select="@name"/> {
316     my $res = "";
317     my @r = unpack "v<xsl:value-of select="@length"/> a*", $data;
318     $data = pop @r;
319     for (@r) {
320     last unless $_;
321     $res .= chr $_;
322     }
323     # dump extra data to file for later analysis
324     #my $x = pack "v*", @r; $x =~ s/^(..)*?\x00\x00//s; open DUMP, ">>/tmp/dump"; print DUMP $x; close DUMP;#d#
325     $res;
326     }
327    
328     sub enc_<xsl:value-of select="@name"/> {
329     $data .= pack "v<xsl:value-of select="@length"/>", map ord, split //, $_[0];
330     }
331     </xsl:template>
332    
333     <xsl:template match="type[@type = 'A']">
334     sub dec_<xsl:value-of select="@name"/> {
335     (my ($r), $data) = unpack "Z<xsl:value-of select="@length"/> a*", $data; $r;
336     }
337    
338     sub enc_<xsl:value-of select="@name"/> {
339     $data .= pack "Z<xsl:value-of select="@length"/>", $_[0];
340     }
341     </xsl:template>
342    
343     <xsl:template match="type[@multiplier]">
344     sub dec_<xsl:value-of select="@name"/> {
345     (1 / <xsl:value-of select="@multiplier"/>) * dec_<xsl:value-of select="@type"/>;
346     }
347    
348     sub enc_<xsl:value-of select="@name"/> {
349     enc_<xsl:value-of select="@type"/> $_[0] * <xsl:value-of select="@multiplier"/>;
350     }
351     </xsl:template>
352    
353     <xsl:template match="member[@array = 'yes']" mode="dec">
354     $r->{<xsl:value-of select="@name"/>} = (my $array = []);
355     while (length $data) {
356     push @$array, dec_<xsl:value-of select="@type"/>
357     <xsl:text> </xsl:text>
358     <xsl:value-of select="@default"/>;
359     }
360     </xsl:template>
361    
362     <xsl:template match="member" mode="dec">
363     $r->{<xsl:value-of select="@name"/>} = dec_<xsl:value-of select="@type"/>
364     <xsl:text> </xsl:text>
365     <xsl:value-of select="@default"/>
366     <xsl:if test="@guard-cond">
367     if ($r->{<xsl:value-of select="@guard-member"/>} <xsl:value-of select="@guard-cond"/>)</xsl:if>
368     <xsl:text>;</xsl:text>
369     </xsl:template>
370    
371     <xsl:template match="member" mode="enc">
372     enc_<xsl:value-of select="@type"/> defined $_[0]{<xsl:value-of select="@name"/>} ? $_[0]{<xsl:value-of select="@name"/>
373     <xsl:text>} : (</xsl:text>
374     <xsl:value-of select="@default"/>
375     <xsl:text>);</xsl:text>
376     </xsl:template>
377    
378     <xsl:template match="struct">
379     sub dec_<xsl:value-of select="@name"/> {
380     my $r = {};
381     <xsl:apply-templates select="member" mode="dec"/>
382     <xsl:if test="@class">
383     bless $r, <xsl:value-of select="@class"/>::;
384     </xsl:if>
385     $r;
386     }
387    
388     sub enc_<xsl:value-of select="@name"/> {
389     <xsl:apply-templates select="member" mode="enc"/>
390     }
391     </xsl:template>
392    
393     <xsl:template match="message">
394     # <xsl:value-of select="@name"/>
395     $dec_<xsl:value-of select="@src"/>{0x<xsl:value-of select="@type"/>} = sub {
396     $data = $_[0];
397     my $r;
398     $r->{type} = "<xsl:value-of select="@name"/>";
399     <xsl:apply-templates select="member" mode="dec"/>
400     $r;
401     };
402     $enc_<xsl:value-of select="@src"/>{<xsl:value-of select="@name"/>} = sub {
403     $data = "";
404     enc_U16 0x<xsl:value-of select="@type"/>;
405     <xsl:apply-templates select="member" mode="enc"/>
406     $data;
407     };
408     </xsl:template>
409    
410     <xsl:template match="member">
411     [<xsl:value-of select="@name"/>
412     <xsl:text>=> "</xsl:text>
413     <xsl:value-of select="@type"/>
414     <xsl:text>", "</xsl:text>
415     <xsl:value-of select="@default"/>
416     <xsl:text>", "</xsl:text>
417     <xsl:value-of select="@guard"/>
418     <xsl:text>;"],</xsl:text>
419     </xsl:template>
420    
421     <xsl:template match="text()">
422     </xsl:template>
423    
424     </xsl:stylesheet>
425