X11 generator: avoid extraneous parens in conditionals.
[metze/wireshark/wip.git] / tools / process-x11-xcb.pl
1 #!/usr/bin/perl
2 #
3 # Script to convert xcbproto and mesa protocol files for
4 # X11 dissector. Creates header files containing code to
5 # dissect X11 extensions.
6 #
7 # Instructions for using this script are in epan/dissectors/README.X11
8 #
9 # Copyright 2008, 2009, 2013, 2014 Open Text Corporation <pharris[AT]opentext.com>
10 #
11 # Wireshark - Network traffic analyzer
12 # By Gerald Combs <gerald@wireshark.org>
13 # Copyright 1998 Gerald Combs
14 #
15 # This program is free software; you can redistribute it and/or
16 # modify it under the terms of the GNU General Public License
17 # as published by the Free Software Foundation; either version 2
18 # of the License, or (at your option) any later version.
19 #
20 # This program is distributed in the hope that it will be useful,
21 # but WITHOUT ANY WARRANTY; without even the implied warranty of
22 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
23 # GNU General Public License for more details.
24 #
25 # You should have received a copy of the GNU General Public License
26 # along with this program; if not, write to the Free Software
27 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
28 #
29
30 #TODO
31 # - support constructs that are legal in XCB, but don't appear to be used
32
33 use 5.010;
34
35 use warnings;
36 use strict;
37
38 # given/when is going to be removed (and/or dramatically altered)
39 # in 5.20. Patches welcome.
40 # Patches even more welcome if they rewrite this whole thing in a
41 # language with a proper compatibility document, such as
42 # http://golang.org/doc/go1compat
43 no if $] >= 5.018, warnings => "experimental::smartmatch";
44
45 use IO::File;
46 use XML::Twig;
47
48 use File::Spec;
49
50 my @reslist = grep {!/xproto\.xml$/} glob File::Spec->catfile('xcbproto', 'src', '*.xml');
51 my @register;
52
53 my %basictype = (
54     char =>   { size => 1, encoding => 'ENC_ASCII|ENC_NA', type => 'FT_STRING', base => 'BASE_NONE',    get => 'VALUE8',  list => 'listOfByte', },
55     void =>   { size => 1, encoding => 'ENC_NA',           type => 'FT_BYTES',  base => 'BASE_NONE',    get => 'VALUE8',  list => 'listOfByte', },
56     BYTE =>   { size => 1, encoding => 'ENC_NA',           type => 'FT_BYTES',  base => 'BASE_NONE',    get => 'VALUE8',  list => 'listOfByte', },
57     CARD8 =>  { size => 1, encoding => 'byte_order',       type => 'FT_UINT8',  base => 'BASE_HEX_DEC', get => 'VALUE8',  list => 'listOfByte', },
58     CARD16 => { size => 2, encoding => 'byte_order',       type => 'FT_UINT16', base => 'BASE_HEX_DEC', get => 'VALUE16', list => 'listOfCard16', },
59     CARD32 => { size => 4, encoding => 'byte_order',       type => 'FT_UINT32', base => 'BASE_HEX_DEC', get => 'VALUE32', list => 'listOfCard32', },
60     CARD64 => { size => 8, encoding => 'byte_order',       type => 'FT_UINT64', base => 'BASE_HEX_DEC', get => 'VALUE64', list => 'listOfCard64', },
61     INT8 =>   { size => 1, encoding => 'byte_order',       type => 'FT_INT8',   base => 'BASE_DEC',     get => 'VALUE8',  list => 'listOfByte', },
62     INT16 =>  { size => 2, encoding => 'byte_order',       type => 'FT_INT16',  base => 'BASE_DEC',     get => 'VALUE16', list => 'listOfInt16', },
63     INT32 =>  { size => 4, encoding => 'byte_order',       type => 'FT_INT32',  base => 'BASE_DEC',     get => 'VALUE32', list => 'listOfInt32', },
64     INT64 =>  { size => 8, encoding => 'byte_order',       type => 'FT_INT64',  base => 'BASE_DEC',     get => 'VALUE64', list => 'listOfInt64', },
65     float =>  { size => 4, encoding => 'byte_order',       type => 'FT_FLOAT',  base => 'BASE_NONE',    get => 'FLOAT',   list => 'listOfFloat', },
66     double => { size => 8, encoding => 'byte_order',       type => 'FT_DOUBLE', base => 'BASE_NONE',    get => 'DOUBLE',  list => 'listOfDouble', },
67     BOOL =>   { size => 1, encoding => 'byte_order',       type => 'FT_BOOLEAN',base => 'BASE_NONE',    get => 'VALUE8',  list => 'listOfByte', },
68 );
69
70 my %simpletype;  # Reset at the beginning of each extension
71 my %gltype;  # No need to reset, since it's only used once
72
73 my %struct =  # Not reset; contains structures already defined.
74               # Also contains this black-list of structures never used by any
75               # extension (to avoid generating useless code).
76 (
77     # structures defined by xproto, but not used by any extension
78     'xproto:CHAR2B' => 1,
79     'xproto:ARC' => 1,
80     'xproto:FORMAT' => 1,
81     'xproto:VISUALTYPE' => 1,
82     'xproto:DEPTH' => 1,
83     'xproto:SCREEN' => 1,
84     'xproto:SetupRequest' => 1,
85     'xproto:SetupFailed' => 1,
86     'xproto:SetupAuthenticate' => 1,
87     'xproto:Setup' => 1,
88     'xproto:TIMECOORD' => 1,
89     'xproto:FONTPROP' => 1,
90     'xproto:CHARINFO' => 1,
91     'xproto:SEGMENT' => 1,
92     'xproto:COLORITEM' => 1,
93     'xproto:RGB' => 1,
94     'xproto:HOST' => 1,
95     'xproto:POINT' => 1,
96
97     # structures defined by xinput, but never used (except by each other)(bug in xcb?)
98     'xinput:KeyInfo' => 1,
99     'xinput:ButtonInfo' => 1,
100     'xinput:ValuatorInfo' => 1,
101     'xinput:KbdFeedbackState' => 1,
102     'xinput:PtrFeedbackState' => 1,
103     'xinput:IntegerFeedbackState' => 1,
104     'xinput:StringFeedbackState' => 1,
105     'xinput:BellFeedbackState' => 1,
106     'xinput:LedFeedbackState' => 1,
107     'xinput:KbdFeedbackCtl' => 1,
108     'xinput:PtrFeedbackCtl' => 1,
109     'xinput:IntegerFeedbackCtl' => 1,
110     'xinput:StringFeedbackCtl' => 1,
111     'xinput:BellFeedbackCtl' => 1,
112     'xinput:LedFeedbackCtl' => 1,
113     'xinput:KeyState' => 1,
114     'xinput:ButtonState' => 1,
115     'xinput:ValuatorState' => 1,
116     'xinput:DeviceResolutionState' => 1,
117     'xinput:DeviceAbsCalibState' => 1,
118     'xinput:DeviceAbsAreaState' => 1,
119     'xinput:DeviceCoreState' => 1,
120     'xinput:DeviceEnableState' => 1,
121     'xinput:DeviceResolutionCtl' => 1,
122     'xinput:DeviceAbsCalibCtl' => 1,
123     'xinput:DeviceAbsAreaCtrl' => 1,
124     'xinput:DeviceCoreCtrl' => 1,
125     'xinput:DeviceEnableCtrl' => 1,
126     'xinput:DeviceName' => 1,
127     'xinput:AddMaster' => 1,
128     'xinput:RemoveMaster' => 1,
129     'xinput:AttachSlave' => 1,
130     'xinput:DetachSlave' => 1,
131     'xinput:ButtonClass' => 1,
132     'xinput:KeyClass' => 1,
133     'xinput:ScrollClass' => 1,
134     'xinput:TouchClass' => 1,
135     'xinput:ValuatorClass' => 1,
136
137     # structures defined by xv, but never used (bug in xcb?)
138     'xv:Image' => 1,
139
140     # structures defined by xkb, but never used (except by each other)(bug in xcb?)
141     'xkb:Key' => 1,
142     'xkb:Outline' => 1,
143     'xkb:Overlay' => 1,
144     'xkb:OverlayKey' => 1,
145     'xkb:OverlayRow' => 1,
146     'xkb:Row' => 1,
147     'xkb:Shape' => 1,
148 );
149 my %enum;  # Not reset; contains enums already defined.
150 my %enum_name;
151 my %type_name;
152 my $header;
153 my $extname;
154 my @incname;
155 my %request;
156 my %genericevent;
157 my %event;
158 my %reply;
159
160 # Output files
161 my $impl;
162 my $reg;
163 my $decl;
164 my $error;
165
166 # glRender sub-op output files
167 my $enum;
168
169 # Mesa API definitions keep moving
170 my @mesas = ('mesa/src/mapi/glapi/gen',  # 2010-04-26
171              'mesa/src/mesa/glapi/gen',  # 2010-02-22
172              'mesa/src/mesa/glapi');     # 2004-05-18
173 my $mesadir = (grep { -d } @mesas)[0];
174
175 sub mesa_category_start {
176     my ($t, $elt) = @_;
177     my $name = $elt->att('name');
178     my $comment;
179     if ($name =~ /^\d\.\d$/) {
180         $comment = "version $name";
181     } else {
182         $comment = "extension $name";
183     }
184
185     print $enum "/* OpenGL $comment */\n";
186     print(" - $comment\n");
187 }
188
189 sub mesa_category {
190     my ($t, $elt) = @_;
191     $t->purge;
192 }
193
194 sub mesa_enum {
195     my ($t, $elt) = @_;
196     my $name = $elt->att('name');
197     my $value = $elt->att('value');
198
199     print $enum "  { $value, \"$name\" },\n" if (length($value) > 3 && length($value) < 10);
200     $t->purge;
201 }
202
203 sub mesa_type {
204     my ($t, $elt) = @_;
205
206     my $name = $elt->att('name');
207     my $size = $elt->att('size');
208     my $float = $elt->att('float');
209     my $unsigned = $elt->att('unsigned');
210     my $base;
211
212     $t->purge;
213
214     if($name eq 'enum') {
215         # enum does not have a direct X equivalent
216         $gltype{'GLenum'} = { size => 4, encoding => 'byte_order', type => 'FT_UINT32', base => 'BASE_HEX',
217                               get => 'VALUE32', list => 'listOfCard32',
218                               val => 'VALS(mesa_enum)', };
219         return;
220     }
221
222     $name = 'GL'.$name;
223     if (defined($float) && $float eq 'true') {
224         $base = 'float';
225         $base = 'double' if ($size == 8);
226     } else {
227         $base = 'INT';
228         if (defined($unsigned) && $unsigned eq 'true') {
229             $base = 'CARD';
230         }
231         $base .= ($size * 8);
232
233         $base = 'BOOL' if ($name eq 'bool');
234         $base = 'BYTE' if ($name eq 'void');
235     }
236
237     $gltype{$name} = $basictype{$base};
238 }
239
240 sub registered_name($$)
241 {
242     my $name = shift;
243     my $field = shift;
244
245     return "hf_x11_$header"."_$name"."_$field";
246 }
247
248 sub mesa_function {
249     my ($t, $elt) = @_;
250     # rop == glRender sub-op
251     # sop == GLX minor opcode
252     my $glx = $elt->first_child('glx');
253     unless(defined $glx) { $t->purge; return; }
254
255     my $rop = $glx->att('rop');
256     unless (defined $rop) { $t->purge; return; }
257
258     # Ideally, we want the main name, not the alias name.
259     # Practically, we'd have to scan the file twice to find
260     # the functions that we want to skip.
261     my $alias = $elt->att('alias');
262     if (defined $alias) { $t->purge; return; }
263
264     my $name = $elt->att('name');
265     $request{$rop} = $name;
266
267     my $image;
268
269     my $length = 0;
270     my @elements = $elt->children('param');
271
272     # Wireshark defines _U_ to mean "Unused" (compiler specific define)
273     if (!@elements) {
274         print $impl <<eot
275 static void mesa_$name(tvbuff_t *tvb _U_, int *offsetp _U_, proto_tree *t _U_, guint byte_order _U_, int length _U_)
276 {
277 eot
278 ;
279     } else {
280         print $impl <<eot
281 static void mesa_$name(tvbuff_t *tvb, int *offsetp, proto_tree *t, guint byte_order, int length _U_)
282 {
283 eot
284 ;
285     }
286
287     my %type_param;
288     foreach my $e (@elements) {
289         # Detect count && variable_param
290         my $count = $e->att('count');
291         my $variable_param = $e->att('variable_param');
292         if (defined $count and defined $variable_param) {
293             $type_param{$variable_param} = 1;
294         }
295     }
296     foreach my $e (@elements) {
297         # Register field with wireshark
298
299         my $type = $e->att('type');
300         $type =~ s/^const //;
301         my $list;
302         $list = 1 if ($type =~ /\*$/);
303         $type =~ s/ \*$//;
304
305         my $fieldname = $e->att('name');
306         my $regname = registered_name($name, $fieldname);
307
308         my $info = $gltype{$type};
309         my $ft = $info->{'type'};
310         my $base = $info->{'base'};
311         my $val = $info->{'val'} // 'NULL';
312         my $count = $e->att('count');
313         my $variable_param = $e->att('variable_param');
314
315         if ($list and $count and $variable_param) {
316             print $decl "static int ${regname} = -1;\n";
317             print $reg "{ &$regname, { \"$fieldname\", \"x11.glx.render.$name.$fieldname\", FT_NONE, BASE_NONE, NULL, 0, NULL, HFILL }},\n";
318             print $decl "static int ${regname}_signed = -1;\n";
319             print $reg "{ &${regname}_signed, { \"$fieldname\", \"x11.glx.render.$name.$fieldname\", FT_INT8, BASE_DEC, NULL, 0, NULL, HFILL }},\n";
320             print $decl "static int ${regname}_unsigned = -1;\n";
321             print $reg "{ &${regname}_unsigned, { \"$fieldname\", \"x11.glx.render.$name.$fieldname\", FT_UINT8, BASE_DEC, NULL, 0, NULL, HFILL }},\n";
322             print $decl "static int ${regname}_item_card16 = -1;\n";
323             print $reg "{ &${regname}_item_card16, { \"$fieldname\", \"x11.glx.render.$name.$fieldname\", FT_UINT16, BASE_DEC, NULL, 0, NULL, HFILL }},\n";
324             print $decl "static int ${regname}_item_int16 = -1;\n";
325             print $reg "{ &${regname}_item_int16, { \"$fieldname\", \"x11.glx.render.$name.$fieldname\", FT_INT16, BASE_DEC, NULL, 0, NULL, HFILL }},\n";
326             print $decl "static int ${regname}_item_card32 = -1;\n";
327             print $reg "{ &${regname}_item_card32, { \"$fieldname\", \"x11.glx.render.$name.$fieldname\", FT_UINT32, BASE_DEC, NULL, 0, NULL, HFILL }},\n";
328             print $decl "static int ${regname}_item_int32 = -1;\n";
329             print $reg "{ &${regname}_item_int32, { \"$fieldname\", \"x11.glx.render.$name.$fieldname\", FT_INT32, BASE_DEC, NULL, 0, NULL, HFILL }},\n";
330             print $decl "static int ${regname}_item_float = -1;\n";
331             print $reg "{ &${regname}_item_float, { \"$fieldname\", \"x11.glx.render.$name.$fieldname\", FT_FLOAT, BASE_NONE, NULL, 0, NULL, HFILL }},\n";
332         } else {
333             print $decl "static int $regname = -1;\n";
334             if ($list and $info->{'size'} > 1) {
335                 print $reg "{ &$regname, { \"$fieldname\", \"x11.glx.render.$name.$fieldname\", FT_NONE, BASE_NONE, NULL, 0, NULL, HFILL }},\n";
336                 $regname .= '_item';
337                 print $decl "static int $regname = -1;\n";
338             }
339             print $reg "{ &$regname, { \"$fieldname\", \"x11.glx.render.$name.$fieldname\", $ft, $base, $val, 0, NULL, HFILL }},\n";
340
341             if ($e->att('counter') or $type_param{$fieldname}) {
342                 print $impl "    int $fieldname;\n";
343             }
344         }
345
346         if ($list) {
347             if ($e->att('img_format')) {
348                 $image = 1;
349                 foreach my $wholename (('swap bytes', 'lsb first')) {
350                     # Boolean values
351                     my $varname = $wholename;
352                     $varname =~ s/\s//g;
353                     my $regname = registered_name($name, $varname);
354                     print $decl "static int $regname = -1;\n";
355                     print $reg "{ &$regname, { \"$wholename\", \"x11.glx.render.$name.$varname\", FT_BOOLEAN, BASE_NONE, NULL, 0, NULL, HFILL }},\n";
356                 }
357                 foreach my $wholename (('row length', 'skip rows', 'skip pixels', 'alignment')) {
358                     # Integer values
359                     my $varname = $wholename;
360                     $varname =~ s/\s//g;
361                     my $regname = registered_name($name, $varname);
362                     print $decl "static int $regname = -1;\n";
363                     print $reg "{ &$regname, { \"$wholename\", \"x11.glx.render.$name.$varname\", FT_UINT32, BASE_HEX_DEC, NULL, 0, NULL, HFILL }},\n";
364                 }
365             }
366         }
367     }
368
369     # The image requests have a few implicit elements first:
370     if ($image) {
371         foreach my $wholename (('swap bytes', 'lsb first')) {
372             # Boolean values
373             my $varname = $wholename;
374             $varname =~ s/\s//g;
375             my $regname = registered_name($name, $varname);
376             print $impl "    proto_tree_add_item(t, $regname, tvb, *offsetp, 1, byte_order);\n";
377             print $impl "    *offsetp += 1;\n";
378             $length += 1;
379         }
380         print $impl "    UNUSED(2);\n";
381         $length += 2;
382         foreach my $wholename (('row length', 'skip rows', 'skip pixels', 'alignment')) {
383             # Integer values
384             my $varname = $wholename;
385             $varname =~ s/\s//g;
386             my $regname = registered_name($name, $varname);
387             print $impl "    proto_tree_add_item(t, $regname, tvb, *offsetp, 4, byte_order);\n";
388             print $impl "    *offsetp += 4;\n";
389             $length += 4;
390         }
391     }
392
393     foreach my $e (@elements) {
394         my $type = $e->att('type');
395         $type =~ s/^const //;
396         my $list;
397         $list = 1 if ($type =~ /\*$/);
398         $type =~ s/ \*$//;
399
400         my $fieldname = $e->att('name');
401         my $regname = registered_name($name, $fieldname);
402
403         my $info = $gltype{$type};
404         my $ft = $info->{'type'};
405         my $base = $info->{'base'};
406
407         if (!$list) {
408             my $size = $info->{'size'};
409             my $encoding = $info->{'encoding'};
410             my $get = $info->{'get'};
411
412             if ($e->att('counter') or $type_param{$fieldname}) {
413                 print $impl "    $fieldname = $get(tvb, *offsetp);\n";
414             }
415             print $impl "    proto_tree_add_item(t, $regname, tvb, *offsetp, $size, $encoding);\n";
416             print $impl "    *offsetp += $size;\n";
417             $length += $size;
418         } else {        # list
419             my $list = $info->{'list'};
420             my $count = $e->att('count');
421             my $variable_param = $e->att('variable_param');
422
423             if (defined($count) && !defined($variable_param)) {
424                 $regname .= ", $regname".'_item' if ($info->{'size'} > 1);
425                 print $impl "    $list(tvb, offsetp, t, $regname, $count, byte_order);\n";
426             } else {
427                 if (defined($count)) {
428                     # Currently, only CallLists has both a count and a variable_param
429                     # The XML contains a size description of all the possibilities
430                     # for CallLists, but not a type description. Implement by hand,
431                     # with the caveat that more types may need to be added in the
432                     # future.
433                     say $impl "    switch($variable_param) {";
434                     say $impl "    case 0x1400: /* BYTE */";
435                     say $impl "        listOfByte(tvb, offsetp, t, ${regname}_signed, $count, byte_order);";
436                     say $impl "        UNUSED(length - $length - $count);";
437                     say $impl "        break;";
438                     say $impl "    case 0x1401: /* UNSIGNED_BYTE */";
439                     say $impl "        listOfByte(tvb, offsetp, t, ${regname}_unsigned, $count, byte_order);";
440                     say $impl "        UNUSED(length - $length - $count);";
441                     say $impl "        break;";
442                     say $impl "    case 0x1402: /* SHORT */";
443                     say $impl "        listOfInt16(tvb, offsetp, t, $regname, ${regname}_item_int16, $count, byte_order);";
444                     say $impl "        UNUSED(length - $length - 2 * $count);";
445                     say $impl "        break;";
446                     say $impl "    case 0x1403: /* UNSIGNED_SHORT */";
447                     say $impl "        listOfCard16(tvb, offsetp, t, $regname, ${regname}_item_card16, $count, byte_order);";
448                     say $impl "        UNUSED(length - $length - 2 * $count);";
449                     say $impl "        break;";
450                     say $impl "    case 0x1404: /* INT */";
451                     say $impl "        listOfInt32(tvb, offsetp, t, $regname, ${regname}_item_int32, $count, byte_order);";
452                     say $impl "        break;";
453                     say $impl "    case 0x1405: /* UNSIGNED_INT */";
454                     say $impl "        listOfCard32(tvb, offsetp, t, $regname, ${regname}_item_card32, $count, byte_order);";
455                     say $impl "        break;";
456                     say $impl "    case 0x1406: /* FLOAT */";
457                     say $impl "        listOfFloat(tvb, offsetp, t, $regname, ${regname}_item_float, $count, byte_order);";
458                     say $impl "        break;";
459                     say $impl "    case 0x1407: /* 2_BYTES */";
460                     say $impl "        listOfCard16(tvb, offsetp, t, $regname, ${regname}_item_card16, $count, ENC_BIG_ENDIAN);";
461                     say $impl "        UNUSED(length - $length - 2 * $count);";
462                     say $impl "        break;";
463                     say $impl "    case 0x1408: /* 3_BYTES */";
464                     say $impl "        UNDECODED(3 * $count);";
465                     say $impl "        UNUSED(length - $length - 3 * $count);";
466                     say $impl "        break;";
467                     say $impl "    case 0x1409: /* 4_BYTES */";
468                     say $impl "        listOfCard32(tvb, offsetp, t, $regname, ${regname}_item_card32, $count, ENC_BIG_ENDIAN);";
469                     say $impl "        break;";
470                     say $impl "    case 0x140B: /* HALF_FLOAT */";
471                     say $impl "        UNDECODED(2 * $count);";
472                     say $impl "        UNUSED(length - $length - 2 * $count);";
473                     say $impl "        break;";
474                     say $impl "    default:     /* Unknown */";
475                     say $impl "        UNDECODED(length - $length);";
476                     say $impl "        break;";
477                     say $impl "    }";
478                 } else {
479                     $regname .= ", $regname".'_item' if ($info->{'size'} > 1);
480                     print $impl "    $list(tvb, offsetp, t, $regname, (length - $length) / $gltype{$type}{'size'}, byte_order);\n";
481                 }
482             }
483         }
484     }
485
486     print $impl "}\n\n";
487     $t->purge;
488 }
489
490 sub get_op($;$);
491 sub get_unop($;$);
492
493 sub get_ref($$)
494 {
495     my $elt = shift;
496     my $refref = shift;
497     my $rv;
498
499     given($elt->name()) {
500         when ('fieldref') {
501             $rv = $elt->text();
502             $refref->{$rv} = 1;
503             $rv = 'f_'.$rv;
504         }
505         when ('value') { $rv = $elt->text(); }
506         when ('op') { $rv = get_op($elt, $refref); }
507         when (['unop','popcount']) { $rv = get_unop($elt, $refref); }
508         default { die "Invalid op fragment: $_" }
509     }
510     return $rv;
511 }
512
513 sub get_op($;$) {
514     my $op = shift;
515     my $refref = shift // {};
516
517     my @elements = $op->children(qr/fieldref|value|op|unop|popcount/);
518     (@elements == 2) or die ("Wrong number of children for 'op'\n");
519     my $left;
520     my $right;
521
522     $left = get_ref($elements[0], $refref);
523     $right = get_ref($elements[1], $refref);
524
525     return "($left " . $op->att('op') . " $right)";
526 }
527
528 sub get_unop($;$) {
529     my $op = shift;
530     my $refref = shift // {};
531
532     my @elements = $op->children(qr/fieldref|value|op|unop|popcount/);
533     (@elements == 1) or die ("Wrong number of children for 'unop'\n");
534     my $left;
535
536     $left = get_ref($elements[0], $refref);
537
538     given ($op->name()) {
539         when ('unop') {
540             return '(' . $op->att('op') . "$left)";
541         }
542         when ('popcount') {
543             return "popcount($left)";
544         }
545         default { die "Invalid unop element $op->name()\n"; }
546     }
547 }
548
549 sub qualname {
550     my $name = shift;
551     $name = $incname[0].':'.$name unless $name =~ /:/;
552     return $name
553 }
554
555 sub get_simple_info {
556     my $name = shift;
557     my $info = $basictype{$name};
558     return $info if (defined $info);
559     $info = $simpletype{$name};
560     return $info if (defined $info);
561     if (defined($type_name{$name})) {
562         return $simpletype{$type_name{$name}};
563     }
564     return undef
565 }
566
567 sub get_struct_info {
568     my $name = shift;
569     my $info = $struct{$name};
570     return $info if (defined $info);
571     if (defined($type_name{$name})) {
572         return $struct{$type_name{$name}};
573     }
574     return undef
575 }
576
577 sub getinfo {
578     my $name = shift;
579     my $info = get_simple_info($name) // get_struct_info($name);
580     # If the script fails here search for $name in this script and remove it from the black list
581     die "$name is defined to be unused in process-x11-xcb.pl but is actually used!" if (defined($info) && $info == "1");
582     return $info;
583 }
584
585 sub dump_enum_values($)
586 {
587     my $e = shift;
588
589     defined($enum{$e}) or die("Enum $e not found");
590
591     my $enumname = "x11_enum_$e";
592     return $enumname if (defined $enum{$e}{done});
593
594     say $enum 'static const value_string '.$enumname.'[] = {';
595
596     my $value = $enum{$e}{value};
597     for my $val (sort { $a <=> $b } keys %$value) {
598         say $enum sprintf("\t{ %3d, \"%s\" },", $val, $$value{$val});
599     }
600     say $enum sprintf("\t{ %3d, NULL },", 0);
601     say $enum '};';
602     say $enum '';
603
604     $enum{$e}{done} = 1;
605     return $enumname;
606 }
607
608 # Find all references, so we can declare only the minimum necessary
609 sub reference_elements($$);
610
611 sub reference_elements($$)
612 {
613     my $e = shift;
614     my $refref = shift;
615
616     given ($e->name()) {
617         when ('switch') {
618             my $lentype = $e->first_child();
619             if (defined $lentype) {
620                 given ($lentype->name()) {
621                     when ('fieldref') { $refref->{field}{$lentype->text()} = 1; }
622                     when ('op') { get_op($lentype, $refref->{field}); }
623                 }
624             }
625
626             my @elements = $e->children(qr/(bit)?case/);
627             for my $case (@elements) {
628                 my @sub_elements = $case->children(qr/list|switch/);
629
630                 foreach my $sub_e (@sub_elements) {
631                     reference_elements($sub_e, $refref);
632                 }
633             }
634         }
635         when ('list') {
636             my $type = $e->att('type');
637             my $info = getinfo($type);
638             if (defined $info->{paramref}) {
639                 for my $pref (keys %{$info->{paramref}}) {
640                     $refref->{field}{$pref} = 1;
641                 }
642             }
643
644             my $lentype = $e->first_child();
645             if (defined $lentype) {
646                 given ($lentype->name()) {
647                     when ('fieldref') { $refref->{field}{$lentype->text()} = 1; }
648                     when ('op') { get_op($lentype, $refref->{field}); }
649                     when (['unop','popcount']) { get_unop($lentype, $refref->{field}); }
650                     when ('sumof') { $refref->{sumof}{$lentype->att('ref')} = 1; }
651                 }
652             } else {
653                 $refref->{field}{'length'} = 1;
654                 $refref->{'length'} = 1;
655             }
656         }
657     }
658 }
659
660 sub register_element($$$$;$)
661 {
662     my $e = shift;
663     my $varpat = shift;
664     my $humanpat = shift;
665     my $refref = shift;
666     my $indent = shift // ' ' x 4;
667
668     given ($e->name()) {
669         when ('pad') { return; }     # Pad has no variables
670         when ('switch') { return; }  # Switch defines varaibles in a tighter scope to avoid collisions
671     }
672
673     # Register field with wireshark
674
675     my $fieldname = $e->att('name');
676     my $type = $e->att('type') or die ("Field $fieldname does not have a valid type\n");
677
678     my $regname = 'hf_x11_'.sprintf ($varpat, $fieldname);
679     my $humanname = 'x11.'.sprintf ($humanpat, $fieldname);
680
681     my $info = getinfo($type);
682     my $ft = $info->{'type'} // 'FT_NONE';
683     my $base = $info->{'base'} // 'BASE_NONE';
684     my $vals = 'NULL';
685
686     my $enum = $e->att('enum') // $e->att('altenum');
687     if (defined $enum) {
688         my $enumname = dump_enum_values($enum_name{$enum});
689         $vals = "VALS($enumname)";
690
691         # Wireshark does not allow FT_BYTES, FT_BOOLEAN, or BASE_NONE to have an enum
692         $ft =~ s/FT_BYTES/FT_UINT8/;
693         $ft =~ s/FT_BOOLEAN/FT_UINT8/;
694         $base =~ s/BASE_NONE/BASE_DEC/;
695     }
696
697     $enum = $e->att('mask');
698     if (defined $enum) {
699         # Create subtree items:
700         defined($enum{$enum_name{$enum}}) or die("Enum $enum not found");
701
702         # Wireshark does not allow FT_BYTES or BASE_NONE to have an enum
703         $ft =~ s/FT_BYTES/FT_UINT8/;
704         $base =~ s/BASE_NONE/BASE_DEC/;
705
706         my $bitsize = $info->{'size'} * 8;
707
708         my $bit = $enum{$enum_name{$enum}}{bit};
709         for my $val (sort { $a <=> $b } keys %$bit) {
710             my $itemname = $$bit{$val};
711             my $item = $regname . '_mask_' . $itemname;
712             my $itemhuman = $humanname . '.' . $itemname;
713             my $bitshift = "1U << $val";
714
715             say $decl "static int $item = -1;";
716             say $reg "{ &$item, { \"$itemname\", \"$itemhuman\", FT_BOOLEAN, $bitsize, NULL, $bitshift, NULL, HFILL }},";
717         }
718     }
719
720     print $decl "static int $regname = -1;\n";
721     if ($e->name() eq 'list' and $info->{'size'} > 1) {
722         print $reg "{ &$regname, { \"$fieldname\", \"$humanname\", FT_NONE, BASE_NONE, NULL, 0, NULL, HFILL }},\n";
723         $regname .= '_item';
724         print $decl "static int $regname = -1;\n";
725     }
726     print $reg "{ &$regname, { \"$fieldname\", \"$humanname\", $ft, $base, $vals, 0, NULL, HFILL }},\n";
727
728     if ($refref->{sumof}{$fieldname}) {
729         print $impl $indent."int sumof_$fieldname = 0;\n";
730     }
731
732     if ($e->name() eq 'field') {
733         if ($refref->{field}{$fieldname} and get_simple_info($type)) {
734             # Pre-declare variable
735             if ($ft eq 'FT_FLOAT') {
736                 print $impl $indent."gfloat f_$fieldname;\n";
737             } elsif ($ft eq 'FT_DOUBLE') {
738                 print $impl $indent."gdouble f_$fieldname;\n";
739             } elsif ($ft eq 'FT_INT64' or $ft eq 'FT_UINT64') {
740                 print $impl $indent."gint64 f_$fieldname;\n";
741             } else {
742                 print $impl $indent."int f_$fieldname;\n";
743             }
744         }
745     }
746 }
747
748 sub dissect_element($$$$$;$$);
749
750 sub dissect_element($$$$$;$$)
751 {
752     my $e = shift;
753     my $varpat = shift;
754     my $humanpat = shift;
755     my $length = shift;
756     my $refref = shift;
757     my $adjustlength = shift;
758     my $indent = shift // ' ' x 4;
759
760     given ($e->name()) {
761         when ('pad') {
762             my $bytes = $e->att('bytes');
763             my $align = $e->att('align');
764             if (defined $bytes) {
765                 print $impl $indent."UNUSED($bytes);\n";
766                 $length += $bytes;
767             } else {
768                 say $impl $indent.'if (*offsetp % '.$align.') {';
769                 say $impl $indent."    UNUSED($align - *offsetp % $align);";
770                 say $impl $indent."}";
771                 if ($length % $align != 0) {
772                     $length += $align - $length % $align;
773                 }
774                 if ($adjustlength) {
775                     say $impl $indent.'length = ((length + '.($align-1).') & ~'.($align-1).');';
776                 }
777             }
778         }
779         when ('field') {
780             my $fieldname = $e->att('name');
781             my $regname = 'hf_x11_'.sprintf ($varpat, $fieldname);
782             my $type = $e->att('type');
783
784             if (get_simple_info($type)) {
785                 my $info = get_simple_info($type);
786                 my $size = $info->{'size'};
787                 my $encoding = $info->{'encoding'};
788                 my $get = $info->{'get'};
789
790                 if ($e->att('enum') // $e->att('altenum')) {
791                     my $fieldsize = $size * 8;
792                     print $impl $indent;
793                     if ($refref->{field}{$fieldname}) {
794                         print $impl "f_$fieldname = ";
795                     }
796                     say $impl "field$fieldsize(tvb, offsetp, t, $regname, byte_order);";
797                 } elsif ($e->att('mask')) {
798                     if ($refref->{field}{$fieldname}) {
799                         say $impl $indent."f_$fieldname = $get(tvb, *offsetp);";
800                     }
801                     say $impl $indent."{";
802                     say $impl $indent."    proto_item *ti = proto_tree_add_item(t, $regname, tvb, *offsetp, $size, $encoding);";
803                     say $impl $indent."    proto_tree *bitmask_tree = proto_item_add_subtree(ti, ett_x11_rectangle);";
804
805                     my $bytesize = $info->{'size'};
806                     my $byteencoding = $info->{'encoding'};
807                     my $bit = $enum{$enum_name{$e->att('mask')}}{bit};
808                     for my $val (sort { $a <=> $b } keys %$bit) {
809                         my $item = $regname . '_mask_' . $$bit{$val};
810
811                         say $impl "$indent    proto_tree_add_item(bitmask_tree, $item, tvb, *offsetp, $bytesize, $byteencoding);";
812                     }
813
814                     say $impl $indent."}";
815                     say $impl $indent."*offsetp += $size;";
816                 } else {
817                     if ($refref->{field}{$fieldname}) {
818                         say $impl $indent."f_$fieldname = $get(tvb, *offsetp);";
819                     }
820                     print $impl $indent."proto_tree_add_item(t, $regname, tvb, *offsetp, $size, $encoding);\n";
821                     print $impl $indent."*offsetp += $size;\n";
822                 }
823                 $length += $size;
824             } elsif (get_struct_info($type)) {
825                 # TODO: variable-lengths (when $info->{'size'} == 0 )
826                 my $info = get_struct_info($type);
827                 $length += $info->{'size'};
828                 print $impl $indent."struct_$info->{'name'}(tvb, offsetp, t, byte_order, 1);\n";
829             } else {
830                 die ("Unrecognized type: $type\n");
831             }
832         }
833         when ('list') {
834             my $fieldname = $e->att('name');
835             my $regname = 'hf_x11_'.sprintf ($varpat, $fieldname);
836             my $type = $e->att('type');
837
838             my $info = getinfo($type);
839             my $lencalc = "(length - $length) / $info->{'size'}";
840             my $lentype = $e->first_child();
841             if (defined $lentype) {
842                 given ($lentype->name()) {
843                     when ('value') { $lencalc = $lentype->text(); }
844                     when ('fieldref') { $lencalc = 'f_'.$lentype->text(); }
845                     when ('paramref') { $lencalc = 'p_'.$lentype->text(); }
846                     when ('op') { $lencalc = get_op($lentype); }
847                     when (['unop','popcount']) { $lencalc = get_unop($lentype); }
848                     when ('sumof') { $lencalc = 'sumof_'.$lentype->att('ref'); }
849                 }
850             }
851
852             if (get_simple_info($type)) {
853                 my $list = $info->{'list'};
854                 my $size = $info->{'size'};
855                 $regname .= ", $regname".'_item' if ($size > 1);
856
857                 if ($refref->{sumof}{$fieldname}) {
858                     my $get = $info->{'get'};
859                     say $impl $indent."{";
860                     say $impl $indent."    int i;";
861                     say $impl $indent."    for (i = 0; i < $lencalc; i++) {";
862                     say $impl $indent."        sumof_$fieldname += $get(tvb, *offsetp + i * $size);";
863                     say $impl $indent."    }";
864                     say $impl $indent."}";
865                 }
866
867                 print $impl $indent."$list(tvb, offsetp, t, $regname, $lencalc, byte_order);\n";
868             } elsif (get_struct_info($type)) {
869                 my $si = get_struct_info($type);
870                 my $prefs = "";
871                 foreach my $pref (sort keys %{$si->{paramref}}) {
872                     $prefs .= ", f_$pref";
873                 }
874
875                 print $impl $indent."struct_$info->{'name'}(tvb, offsetp, t, byte_order, $lencalc$prefs);\n";
876             } else {
877                 die ("Unrecognized type: $type\n");
878             }
879
880             if ($adjustlength && defined($lentype)) {
881               # Some requests end with a list of unspecified length
882               # Adjust the length field here so that the next $lencalc will be accurate
883               say $impl $indent."length -= $lencalc * $info->{'size'};";
884             }
885         }
886         when ('switch') {
887             my $switchtype = $e->first_child() or die("Switch element not defined");
888
889             my $switchon = get_ref($switchtype, {});
890             my @elements = $e->children(qr/(bit)?case/);
891             for my $case (@elements) {
892                 my @refs = $case->children('enumref');
893                 my @test;
894                 my $fieldname;
895                 foreach my $ref (@refs) {
896                     my $enum_ref = $ref->att('ref');
897                     my $field = $ref->text();
898                     $fieldname //= $field; # Use first named field
899                     if ($case->name() eq 'bitcase') {
900                         my $bit = $enum{$enum_name{$enum_ref}}{rbit}{$field};
901                         if (! defined($bit)) {
902                             for my $foo (keys %{$enum{$enum_name{$enum_ref}}{rbit}}) { say "'$foo'"; }
903                             die ("Field '$field' not found in '$enum_ref'");
904                         }
905                         push @test , "$switchon & (1U << $bit)";
906                     } else {
907                         my $val = $enum{$enum_name{$enum_ref}}{rvalue}{$field};
908                         if (! defined($val)) {
909                             for my $foo (keys %{$enum{$enum_name{$enum_ref}}{rvalue}}) { say "'$foo'"; }
910                             die ("Field '$field' not found in '$enum_ref'");
911                         }
912                         push @test , "$switchon == $val";
913                     }
914                 }
915
916                 if (@test > 1) {
917                     # We have more than one conditional, add parentheses to them.
918                     # We don't add parentheses to all the conditionals because
919                     # clang complains about the extra parens if you do "if ((x == y))".
920                     my @tests_with_parens;
921                     foreach my $conditional (@test) {
922                         push @tests_with_parens, "($conditional)";
923                     }
924
925                     @test = @tests_with_parens;
926                 }
927
928                 my $list = join ' || ', @test;
929                 say $impl $indent."if ($list) {";
930
931                 my $vp = $varpat;
932                 my $hp = $humanpat;
933
934                 $vp =~ s/%s/${fieldname}_%s/;
935                 $hp =~ s/%s/${fieldname}.%s/;
936
937                 my @sub_elements = $case->children(qr/pad|field|list|switch/);
938
939                 my $subref = { field => {}, sumof => {} };
940                 foreach my $sub_e (@sub_elements) {
941                     reference_elements($sub_e, $subref);
942                 }
943                 foreach my $sub_e (@sub_elements) {
944                     register_element($sub_e, $vp, $hp, $subref, $indent . '    ');
945                 }
946                 foreach my $sub_e (@sub_elements) {
947                     $length = dissect_element($sub_e, $vp, $hp, $length, $subref, $adjustlength, $indent . '    ');
948                 }
949
950                 say $impl $indent."}";
951             }
952         }
953         default { die "Unknown field type: $_\n"; }
954     }
955     return $length;
956 }
957
958 sub struct {
959     my ($t, $elt) = @_;
960     my $name = $elt->att('name');
961     my $qualname = qualname($name);
962     $type_name{$name} = $qualname;
963
964     if (defined $struct{$qualname}) {
965         $t->purge;
966         return;
967     }
968
969     my @elements = $elt->children(qr/pad|field|list|switch/);
970
971     print(" - Struct $name\n");
972
973     $name = $qualname;
974     $name =~ s/:/_/;
975
976     my %refs;
977     my %paramrefs;
978     my $size = 0;
979     my $dynamic = 0;
980     my $needi = 0;
981     # Find struct size
982     foreach my $e (@elements) {
983         my $count;
984         $count = 1;
985         given ($e->name()) {
986             when ('pad') {
987                 my $bytes = $e->att('bytes');
988                 my $align = $e->att('align');
989                 if (defined $bytes) {
990                     $size += $bytes;
991                     next;
992                 }
993                 if (!$dynamic) {
994                     if ($size % $align) {
995                         $size += $align - $size % $align;
996                     }
997                 }
998                 next;
999             }
1000             when ('list') {
1001                 my $type = $e->att('type');
1002                 my $info = getinfo($type);
1003
1004                 $needi = 1 if ($info->{'size'} == 0);
1005
1006                 my $value = $e->first_child();
1007                 given($value->name()) {
1008                     when ('fieldref') {
1009                         $refs{$value->text()} = 1;
1010                         $count = 0;
1011                         $dynamic = 1;
1012                     }
1013                     when ('paramref') {
1014                         $paramrefs{$value->text()} = $value->att('type');
1015                         $count = 0;
1016                         $dynamic = 1;
1017                     }
1018                     when ('op') {
1019                         get_op($value, \%refs);
1020                         $count = 0;
1021                         $dynamic = 1;
1022                     }
1023                     when (['unop','popcount']) {
1024                         get_unop($value, \%refs);
1025                         $count = 0;
1026                         $dynamic = 1;
1027                     }
1028                     when ('value') {
1029                         $count = $value->text();
1030                     }
1031                     default { die("Invalid list size $_\n"); }
1032                 }
1033             }
1034             when ('field') { }
1035             when ('switch') {
1036                 $dynamic = 1;
1037                 next;
1038             }
1039             default { die("unrecognized field: $_\n"); }
1040         }
1041
1042         my $type = $e->att('type');
1043         my $info = getinfo($type);
1044
1045         $size += $info->{'size'} * $count;
1046     }
1047
1048     my $prefs = "";
1049
1050     if ($dynamic) {
1051         $size = 0;
1052
1053         foreach my $pref (sort keys %paramrefs) {
1054             $prefs .= ", int p_$pref";
1055         }
1056
1057         print $impl <<eot
1058
1059 static int struct_size_$name(tvbuff_t *tvb _U_, int *offsetp _U_, guint byte_order _U_$prefs)
1060 {
1061     int size = 0;
1062 eot
1063 ;
1064         say $impl '    int i, off;' if ($needi);
1065
1066         foreach my $ref (sort keys %refs) {
1067             say $impl "    int f_$ref;";
1068         }
1069
1070         foreach my $e (@elements) {
1071             my $count;
1072             $count = 1;
1073
1074             my $type = $e->att('type') // '';
1075             my $info = getinfo($type);
1076
1077             given ($e->name()) {
1078                 when ('pad') {
1079                     my $bytes = $e->att('bytes');
1080                     my $align = $e->att('align');
1081                     if (defined $bytes) {
1082                         $size += $bytes;
1083                     } else {
1084                         say $impl '    size = (size + '.($align-1).') & ~'.($align-1).';';
1085                     }
1086                 }
1087                 when ('list') {
1088                     my $len = $e->first_child();
1089                     my $infosize = $info->{'size'};
1090                     my $sizemul;
1091
1092                     given ($len->name()) {
1093                         when ('op') { $sizemul = get_op($len, \%refs); }
1094                         when (['unop','popcount']) { $sizemul = get_unop($len, \%refs); }
1095                         when ('fieldref') { $sizemul = 'f_'.$len->text(); }
1096                         when ('paramref') { $sizemul = 'p_'.$len->text(); }
1097                         when ('value') {
1098                             if ($infosize) {
1099                                 $size += $infosize * $len->text();
1100                             } else {
1101                                 $sizemul = $len->text();
1102                             }
1103                         }
1104                         default { die "Invalid list size: $_\n"; }
1105                     }
1106                     if (defined $sizemul) {
1107                         if ($infosize) {
1108                             say $impl "    size += $sizemul * $infosize;";
1109                         } else {
1110                             say $impl "    for (i = 0; i < $sizemul; i++) {";
1111                             say $impl "        off = (*offsetp) + size + $size;";
1112                             say $impl "        size += struct_size_$info->{name}(tvb, &off, byte_order);";
1113                             say $impl '    }';
1114                         }
1115                     }
1116                 }
1117                 when ('field') {
1118                     my $fname = $e->att('name');
1119                     if (defined($refs{$fname})) {
1120                         say $impl "    f_$fname = $info->{'get'}(tvb, *offsetp + size + $size);";
1121                     }
1122                     $size += $info->{'size'};
1123                 }
1124             }
1125         }
1126         say $impl "    return size + $size;";
1127         say $impl '}';
1128         $size = 0; # 0 means "dynamic calcuation required"
1129     }
1130
1131     print $decl "static int hf_x11_struct_$name = -1;\n";
1132     print $reg "{ &hf_x11_struct_$name, { \"$name\", \"x11.struct.$name\", FT_NONE, BASE_NONE, NULL, 0, NULL, HFILL }},\n";
1133
1134     print $impl <<eot
1135
1136 static void struct_$name(tvbuff_t *tvb, int *offsetp, proto_tree *root, guint byte_order _U_, int count$prefs)
1137 {
1138     int i;
1139     for (i = 0; i < count; i++) {
1140         proto_item *item;
1141         proto_tree *t;
1142 eot
1143 ;
1144
1145     my $varpat = 'struct_'.$name.'_%s';
1146     my $humanpat = "struct.$name.%s";
1147     my $refs = { field => {}, sumof => {} };
1148
1149     foreach my $e (@elements) {
1150         reference_elements($e, $refs);
1151     }
1152     foreach my $e (@elements) {
1153         register_element($e, $varpat, $humanpat, $refs, "\t");
1154     }
1155
1156     $prefs = "";
1157     foreach my $pref (sort keys %paramrefs) {
1158         $prefs .= ", p_$pref";
1159     }
1160
1161     my $sizecalc = $size;
1162     $size or $sizecalc = "struct_size_$name(tvb, offsetp, byte_order$prefs)";
1163
1164     print $impl <<eot
1165
1166         item = proto_tree_add_item(root, hf_x11_struct_$name, tvb, *offsetp, $sizecalc, ENC_NA);
1167         t = proto_item_add_subtree(item, ett_x11_rectangle);
1168 eot
1169 ;
1170     my $length = 0;
1171     foreach my $e (@elements) {
1172         $length = dissect_element($e, $varpat, $humanpat, $length, $refs, 0, "\t");
1173     }
1174
1175     print $impl "    }\n}\n";
1176     $struct{$qualname} = { size => $size, name => $name, paramref => \%paramrefs };
1177     $t->purge;
1178 }
1179
1180 sub union {
1181     # TODO proper dissection
1182     #
1183     # Right now, the only extension to use a union is randr.
1184     # for now, punt.
1185     my ($t, $elt) = @_;
1186     my $name = $elt->att('name');
1187     my $qualname = qualname($name);
1188     $type_name{$name} = $qualname;
1189
1190     if (defined $struct{$qualname}) {
1191         $t->purge;
1192         return;
1193     }
1194
1195     my @elements = $elt->children(qr/field/);
1196     my @sizes;
1197
1198     print(" - Union $name\n");
1199
1200     $name = $qualname;
1201     $name =~ s/:/_/;
1202
1203     # Find union size
1204     foreach my $e (@elements) {
1205         my $type = $e->att('type');
1206         my $info = getinfo($type);
1207
1208         $info->{'size'} > 0 or die ("Error: Union containing variable sized struct $type\n");
1209         push @sizes, $info->{'size'};
1210     }
1211     @sizes = sort {$b <=> $a} @sizes;
1212     my $size = $sizes[0];
1213
1214     print $decl "static int hf_x11_union_$name = -1;\n";
1215     print $reg "{ &hf_x11_union_$name, { \"$name\", \"x11.union.$name\", FT_NONE, BASE_NONE, NULL, 0, NULL, HFILL }},\n";
1216
1217     print $impl <<eot
1218
1219 static void struct_$name(tvbuff_t *tvb, int *offsetp, proto_tree *root, guint byte_order, int count)
1220 {
1221     int i;
1222     int base = *offsetp;
1223     for (i = 0; i < count; i++) {
1224         proto_item *item;
1225         proto_tree *t;
1226 eot
1227 ;
1228
1229     my $varpat = 'union_'.$name.'_%s';
1230     my $humanpat = "union.$name.%s";
1231     my $refs = { field => {}, sumof => {} };
1232
1233     foreach my $e (@elements) {
1234         reference_elements($e, $refs);
1235     }
1236     foreach my $e (@elements) {
1237         register_element($e, $varpat, $humanpat, $refs, "\t");
1238     }
1239
1240     print $impl <<eot
1241         item = proto_tree_add_item(root, hf_x11_union_$name, tvb, base, $size, ENC_NA);
1242         t = proto_item_add_subtree(item, ett_x11_rectangle);
1243
1244 eot
1245 ;
1246
1247     foreach my $e (@elements) {
1248         say $impl '        *offsetp = base;';
1249         dissect_element($e, $varpat, $humanpat, 0, $refs, 0, "\t");
1250     }
1251     say $impl "        base += $size;";
1252     say $impl '    }';
1253     say $impl '    *offsetp = base;';
1254     say $impl '}';
1255
1256     $struct{$qualname} = { size => $size, name => $name };
1257     $t->purge;
1258 }
1259
1260 sub enum {
1261     my ($t, $elt) = @_;
1262     my $name = $elt->att('name');
1263     my $fullname = $incname[0].'_'.$name;
1264
1265     $enum_name{$name} = $fullname;
1266     $enum_name{$incname[0].':'.$name} = $fullname;
1267
1268     if (defined $enum{$fullname}) {
1269         $t->purge;
1270         return;
1271     }
1272
1273     my @elements = $elt->children('item');
1274
1275     print(" - Enum $name\n");
1276
1277     my $value = {};
1278     my $bit = {};
1279     my $rvalue = {};
1280     my $rbit = {};
1281     $enum{$fullname} = { value => $value, bit => $bit, rbit => $rbit, rvalue => $rvalue };
1282
1283     my $nextvalue = 0;
1284
1285     foreach my $e (@elements) {
1286         my $n = $e->att('name');
1287         my $valtype = $e->first_child(qr/value|bit/);
1288         if (defined $valtype) {
1289             my $val = int($valtype->text());
1290             given ($valtype->name()) {
1291                 when ('value') {
1292                     $$value{$val} = $n;
1293                     $$rvalue{$n} = $val;
1294                     $nextvalue = $val + 1;
1295
1296                     # Ugly hack to support (temporary, hopefully) ugly
1297                     # hack in xinput:ChangeDeviceProperty
1298                     # Register certain values as bits also
1299                     given ($val) {
1300                         when (8) {
1301                             $$bit{'3'} = $n;
1302                             $$rbit{$n} = 3;
1303                         }
1304                         when (16) {
1305                             $$bit{'4'} = $n;
1306                             $$rbit{$n} = 4;
1307                         }
1308                         when (32) {
1309                             $$bit{'5'} = $n;
1310                             $$rbit{$n} = 5;
1311                         }
1312                     }
1313                 }
1314                 when ('bit') {
1315                     $$bit{$val} = $n;
1316                     $$rbit{$n} = $val;
1317                 }
1318             }
1319         } else {
1320             $$value{$nextvalue} = $n;
1321             $nextvalue++;
1322         }
1323     }
1324
1325     $t->purge;
1326 }
1327
1328 sub request {
1329     my ($t, $elt) = @_;
1330     my $name = $elt->att('name');
1331
1332     print(" - Request $name\n");
1333     $request{$elt->att('opcode')} = $name;
1334
1335     my $length = 4;
1336     my @elements = $elt->children(qr/pad|field|list|switch/);
1337
1338     # Wireshark defines _U_ to mean "Unused" (compiler specific define)
1339     if (!@elements) {
1340         print $impl <<eot
1341
1342 static void $header$name(tvbuff_t *tvb _U_, packet_info *pinfo _U_, int *offsetp _U_, proto_tree *t _U_, guint byte_order _U_, int length _U_)
1343 {
1344 eot
1345 ;
1346     } else {
1347         print $impl <<eot
1348
1349 static void $header$name(tvbuff_t *tvb, packet_info *pinfo _U_, int *offsetp, proto_tree *t, guint byte_order, int length _U_)
1350 {
1351 eot
1352 ;
1353     }
1354     my $varpat = $header.'_'.$name.'_%s';
1355     my $humanpat = "$header.$name.%s";
1356     my $refs = { field => {}, sumof => {} };
1357
1358     foreach my $e (@elements) {
1359         reference_elements($e, $refs);
1360     }
1361     foreach my $e (@elements) {
1362         register_element($e, $varpat, $humanpat, $refs);
1363     }
1364
1365     foreach my $e (@elements) {
1366         if ($e->name() eq 'list' && $name eq 'Render' && $e->att('name') eq 'data' && -e "$mesadir/gl_API.xml") {
1367             # Special case: Use mesa-generated dissector for 'data'
1368             print $impl "    dispatch_glx_render(tvb, pinfo, offsetp, t, byte_order, (length - $length));\n";
1369         } else {
1370             $length = dissect_element($e, $varpat, $humanpat, $length, $refs, 1);
1371         }
1372     }
1373
1374     say $impl '}';
1375
1376     my $reply = $elt->first_child('reply');
1377     if ($reply) {
1378         $reply{$elt->att('opcode')} = $name;
1379
1380         $varpat = $header.'_'.$name.'_reply_%s';
1381         $humanpat = "$header.$name.reply.%s";
1382
1383         @elements = $reply->children(qr/pad|field|list|switch/);
1384
1385         # Wireshark defines _U_ to mean "Unused" (compiler specific define)
1386         if (!@elements) {
1387             say $impl "static void $header$name"."_Reply(tvbuff_t *tvb _U_, packet_info *pinfo, int *offsetp _U_, proto_tree *t _U_, guint byte_order _U_)\n{";
1388         } else {
1389             say $impl "static void $header$name"."_Reply(tvbuff_t *tvb, packet_info *pinfo, int *offsetp, proto_tree *t, guint byte_order)\n{";
1390         }
1391         say $impl '    int sequence_number;' if (@elements);
1392
1393         my $refs = { field => {}, sumof => {} };
1394         foreach my $e (@elements) {
1395             reference_elements($e, $refs);
1396         }
1397
1398         say $impl '    int f_length;'        if ($refs->{field}{'length'});
1399         say $impl '    int length;'          if ($refs->{length});
1400         foreach my $e (@elements) {
1401             register_element($e, $varpat, $humanpat, $refs);
1402         }
1403
1404         say $impl '';
1405         say $impl '    col_append_fstr(pinfo->cinfo, COL_INFO, "-'.$name.'");';
1406         say $impl '';
1407         say $impl '    REPLY(reply);';
1408
1409         my $first = 1;
1410         my $length = 1;
1411         foreach my $e (@elements) {
1412             $length = dissect_element($e, $varpat, $humanpat, $length, $refs);
1413             if ($first) {
1414                 $first = 0;
1415                 say $impl '    sequence_number = VALUE16(tvb, *offsetp);';
1416                 say $impl '    proto_tree_add_uint_format(t, hf_x11_reply_sequencenumber, tvb, *offsetp, 2, sequence_number,';
1417                 say $impl '            "sequencenumber: %d ('.$header.'-'.$name.')", sequence_number);';
1418                 say $impl '    *offsetp += 2;';
1419
1420                 if ($refs->{field}{length}) {
1421                     say $impl '    f_length = VALUE32(tvb, *offsetp);';
1422                 }
1423                 if ($refs->{length}) {
1424                     say $impl '    length = f_length * 4 + 32;';
1425                 }
1426                 say $impl '    proto_tree_add_item(t, hf_x11_replylength, tvb, *offsetp, 4, byte_order);';
1427                 say $impl '    *offsetp += 4;';
1428
1429                 $length += 6;
1430             }
1431         }
1432
1433         say $impl '}';
1434     }
1435     $t->purge;
1436 }
1437
1438 sub defxid(@) {
1439     my $name;
1440     while ($name = shift) {
1441         my $qualname = qualname($name);
1442         $simpletype{$qualname} = { size => 4, encoding => 'byte_order', type => 'FT_UINT32',  base => 'BASE_HEX',  get => 'VALUE32', list => 'listOfCard32', };
1443         $type_name{$name} = $qualname;
1444     }
1445 }
1446
1447 sub xidtype {
1448     my ($t, $elt) = @_;
1449     my $name = $elt->att('name');
1450
1451     defxid($name);
1452
1453     $t->purge;
1454 }
1455
1456 sub typedef {
1457     my ($t, $elt) = @_;
1458     my $oldname = $elt->att('oldname');
1459     my $newname = $elt->att('newname');
1460     my $qualname = qualname($newname);
1461
1462     # Duplicate the type
1463     my $info = get_simple_info($oldname);
1464     if ($info) {
1465         $simpletype{$qualname} = $info;
1466     } elsif ($info = get_struct_info($oldname)) {
1467         $struct{$qualname} = $info;
1468     } else {
1469         die ("$oldname not found while attempting to typedef $newname\n");
1470     }
1471     $type_name{$newname} = $qualname;
1472
1473     $t->purge;
1474 }
1475
1476 sub error {
1477     my ($t, $elt) = @_;
1478
1479     my $number = $elt->att('number');
1480     if ($number >= 0) {
1481         my $name = $elt->att('name');
1482         print $error "  \"$header-$name\",\n";
1483     }
1484
1485     $t->purge;
1486 }
1487
1488 sub event {
1489     my ($t, $elt) = @_;
1490
1491     my $number = $elt->att('number');
1492     $number or return;
1493
1494     my $name = $elt->att('name');
1495     my $xge = $elt->att('xge');
1496
1497     if ($xge) {
1498         $genericevent{$number} = $name;
1499     } else {
1500         $event{$number} = $name;
1501     }
1502
1503     my $length = 1;
1504     my @elements = $elt->children(qr/pad|field|list|switch/);
1505
1506     # Wireshark defines _U_ to mean "Unused" (compiler specific define)
1507     if (!@elements) {
1508         if ($xge) {
1509             print $impl <<eot
1510
1511 static void $header$name(tvbuff_t *tvb _U_, int length _U_, int *offsetp _U_, proto_tree *t _U_, guint byte_order _U_)
1512 {
1513         } else {
1514             print $impl <<eot
1515
1516 static void $header$name(tvbuff_t *tvb _U_, int *offsetp _U_, proto_tree *t _U_, guint byte_order _U_)
1517 {
1518 eot
1519 ;
1520         }
1521     } else {
1522         if ($xge) {
1523             $length = 10;
1524             print $impl <<eot
1525
1526 static void $header$name(tvbuff_t *tvb, int length _U_, int *offsetp, proto_tree *t, guint byte_order)
1527 {
1528 eot
1529 ;
1530         } else {
1531             print $impl <<eot
1532
1533 static void $header$name(tvbuff_t *tvb, int *offsetp, proto_tree *t, guint byte_order)
1534 {
1535 eot
1536 ;
1537         }
1538     }
1539
1540     my $varpat = $header.'_'.$name.'_%s';
1541     my $humanpat = "$header.$name.%s";
1542     my $refs = { field => {}, sumof => {} };
1543
1544     foreach my $e (@elements) {
1545         reference_elements($e, $refs);
1546     }
1547     foreach my $e (@elements) {
1548         register_element($e, $varpat, $humanpat, $refs);
1549     }
1550
1551     if ($xge) {
1552         say $impl "    proto_tree_add_uint_format(t, hf_x11_minor_opcode, tvb, *offsetp, 2, $number,";
1553         say $impl "                               \"opcode: $name ($number)\");";
1554         foreach my $e (@elements) {
1555             $length = dissect_element($e, $varpat, $humanpat, $length, $refs);
1556         }
1557     } else {
1558         my $first = 1;
1559         foreach my $e (@elements) {
1560             $length = dissect_element($e, $varpat, $humanpat, $length, $refs);
1561             if ($first) {
1562                 $first = 0;
1563                 say $impl "    CARD16(event_sequencenumber);";
1564             }
1565         }
1566     }
1567
1568     say $impl "}\n";
1569
1570     $t->purge;
1571 }
1572
1573 sub include_start {
1574     my ($t, $elt) = @_;
1575     my $header = $elt->att('header');
1576     unshift @incname, $header;
1577 }
1578
1579 sub include_end {
1580     shift @incname;
1581 }
1582
1583 sub include
1584 {
1585     my ($t, $elt) = @_;
1586     my $include = $elt->text();
1587
1588     print " - Import $include\n";
1589     my $xml = XML::Twig->new(
1590                 start_tag_handlers => {
1591                     'xcb' => \&include_start,
1592                 },
1593                 twig_roots => {
1594                     'import' => \&include,
1595                     'struct' => \&struct,
1596                     'xidtype' => \&xidtype,
1597                     'xidunion' => \&xidtype,
1598                     'typedef' => \&typedef,
1599                     'enum' => \&enum,
1600                 },
1601                 end_tag_handlers => {
1602                     'xcb' => \&include_end,
1603                 });
1604     $xml->parsefile("xcbproto/src/$include.xml") or die ("Cannot open $include.xml\n");
1605
1606     $t->purge;
1607 }
1608
1609
1610 sub xcb_start {
1611     my ($t, $elt) = @_;
1612     $header = $elt->att('header');
1613     $extname = ($elt->att('extension-name') or $header);
1614     unshift @incname, $header;
1615
1616     print("Extension $extname\n");
1617
1618     undef %request;
1619     undef %genericevent;
1620     undef %event;
1621     undef %reply;
1622
1623     %simpletype = ();
1624     %enum_name = ();
1625     %type_name = ();
1626
1627     print $error "const char *$header"."_errors[] = {\n";
1628 }
1629
1630 sub xcb {
1631     my ($t, $elt) = @_;
1632
1633     my $xextname = $elt->att('extension-xname');
1634     my $lookup_name = $header . "_extension_minor";
1635     my $error_name = $header . "_errors";
1636     my $event_name = $header . "_events";
1637     my $genevent_name = 'NULL';
1638     my $reply_name = $header . "_replies";
1639
1640     print $decl "static int hf_x11_$lookup_name = -1;\n\n";
1641
1642     print $impl "static const value_string $lookup_name"."[] = {\n";
1643     foreach my $req (sort {$a <=> $b} keys %request) {
1644         print $impl "    { $req, \"$request{$req}\" },\n";
1645     }
1646     print $impl "    { 0, NULL }\n";
1647     print $impl "};\n";
1648
1649     say $impl "const x11_event_info $event_name".'[] = {';
1650     foreach my $e (sort {$a <=> $b} keys %event) {
1651         say $impl "    { \"$header-$event{$e}\", $header$event{$e} },";
1652     }
1653     say $impl '    { NULL, NULL }';
1654     say $impl '};';
1655
1656     if (%genericevent) {
1657         $genevent_name = $header.'_generic_events';
1658         say $impl 'static const x11_generic_event_info '.$genevent_name.'[] = {';
1659
1660         for my $val (sort { $a <=> $b } keys %genericevent) {
1661             say $impl sprintf("\t{ %3d, %s },", $val, $header.$genericevent{$val});
1662         }
1663         say $impl sprintf("\t{ %3d, NULL },", 0);
1664         say $impl '};';
1665         say $impl '';
1666     }
1667
1668     print $impl "static x11_reply_info $reply_name"."[] = {\n";
1669     foreach my $e (sort {$a <=> $b} keys %reply) {
1670         print $impl "    { $e, $header$reply{$e}_Reply },\n";
1671     }
1672     print $impl "    { 0, NULL }\n";
1673     print $impl "};\n";
1674
1675     print $reg "{ &hf_x11_$lookup_name, { \"extension-minor\", \"x11.extension-minor\", FT_UINT8, BASE_DEC, VALS($lookup_name), 0, \"minor opcode\", HFILL }},\n\n";
1676
1677     print $impl <<eot
1678
1679 static void dispatch_$header(tvbuff_t *tvb, packet_info *pinfo, int *offsetp, proto_tree *t, guint byte_order)
1680 {
1681     int minor, length;
1682     minor = CARD8($lookup_name);
1683     length = REQUEST_LENGTH();
1684
1685     col_append_fstr(pinfo->cinfo, COL_INFO, "-%s",
1686                           val_to_str(minor, $lookup_name,
1687                                      "<Unknown opcode %d>"));
1688     switch (minor) {
1689 eot
1690     ;
1691
1692     foreach my $req (sort {$a <=> $b} keys %request) {
1693         print $impl "    case $req:\n";
1694         print $impl "\t$header$request{$req}(tvb, pinfo, offsetp, t, byte_order, length);\n";
1695         print $impl "\tbreak;\n";
1696     }
1697     say $impl "    /* No need for a default case here, since Unknown is printed above,";
1698     say $impl "       and UNDECODED() is taken care of by dissect_x11_request */";
1699     print $impl "    }\n}\n";
1700     print $impl <<eot
1701
1702 static void register_$header(void)
1703 {
1704     set_handler("$xextname", dispatch_$header, $error_name, $event_name, $genevent_name, $reply_name);
1705 }
1706 eot
1707     ;
1708
1709     print $error "  NULL\n};\n\n";
1710
1711     push @register, $header;
1712 }
1713
1714 sub find_version {
1715     #my $git = `which git`;
1716     #chomp($git);
1717     #-x $git or return 'unknown';
1718
1719     my $lib = shift;
1720     # this will generate an error on stderr if git isn't in our $PATH
1721     # but that's OK.  The version is still set to 'unknown' in that case
1722     # and at least the operator could see it.
1723     my $ver = `git --git-dir=$lib/.git describe --tags`;
1724     $ver //= 'unknown';
1725     chomp $ver;
1726     return $ver;
1727 }
1728
1729 sub add_generated_header {
1730     my ($out, $using) = @_;
1731     my $ver = find_version($using);
1732
1733     print $out <<eot
1734 /* Do not modify this file. */
1735 /* It was automatically generated by $0
1736    using $using version $ver */
1737 eot
1738     ;
1739
1740     # Add license text
1741     print $out <<eot
1742 /*
1743  * Copyright 2008, 2009, 2013, 2014 Open Text Corporation <pharris[AT]opentext.com>
1744  *
1745  * Wireshark - Network traffic analyzer
1746  * By Gerald Combs <gerald[AT]wireshark.org>
1747  * Copyright 1998 Gerald Combs
1748  *
1749  * This program is free software; you can redistribute it and/or modify
1750  * it under the terms of the GNU General Public License as published by
1751  * the Free Software Foundation; either version 2 of the License, or
1752  * (at your option) any later version.
1753  *
1754  * This program is distributed in the hope that it will be useful,
1755  * but WITHOUT ANY WARRANTY; without even the implied warranty of
1756  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1757  * GNU General Public License for more details.
1758  *
1759  * You should have received a copy of the GNU General Public License along
1760  * with this program; if not, write to the Free Software Foundation, Inc.,
1761  * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
1762  */
1763
1764 eot
1765     ;
1766 }
1767
1768 # initialize core X11 protocol
1769 # Do this in the Makefile now
1770 #system('./process-x11-fields.pl < x11-fields');
1771
1772 # Extension implementation
1773 $impl = new IO::File '> x11-extension-implementation.h'
1774             or die ("Cannot open x11-extension-implementation.h for writing\n");
1775 $error = new IO::File '> x11-extension-errors.h'
1776             or die ("Cannot open x11-extension-errors.h for writing\n");
1777
1778 add_generated_header($impl, 'xcbproto');
1779 add_generated_header($error, 'xcbproto');
1780
1781 # Open the files generated by process-x11-fields.pl for appending
1782 $reg = new IO::File '>> x11-register-info.h'
1783             or die ("Cannot open x11-register-info.h for appending\n");
1784 $decl = new IO::File '>> x11-declarations.h'
1785             or die ("Cannot open x11-declarations.h for appending\n");
1786
1787 print $reg "\n/* Generated by $0 below this line */\n";
1788 print $decl "\n/* Generated by $0 below this line */\n";
1789
1790 # Mesa for glRender
1791 if (-e "$mesadir/gl_API.xml") {
1792     $enum = new IO::File '> x11-glx-render-enum.h'
1793             or die ("Cannot open x11-glx-render-enum.h for writing\n");
1794     add_generated_header($enum, 'mesa');
1795     print $enum "static const value_string mesa_enum[] = {\n";
1796     print $impl '#include "x11-glx-render-enum.h"'."\n\n";
1797
1798     print("Mesa glRender:\n");
1799     $header = "glx_render";
1800
1801     my $xml = XML::Twig->new(
1802                 start_tag_handlers => {
1803                     'category' => \&mesa_category_start,
1804                 },
1805                 twig_roots => {
1806                     'category' => \&mesa_category,
1807                     'enum' => \&mesa_enum,
1808                     'type' => \&mesa_type,
1809                     'function' => \&mesa_function,
1810                 });
1811     $xml->parsefile("$mesadir/gl_API.xml") or die ("Cannot open gl_API\n");
1812
1813     print $enum "    { 0, NULL }\n";
1814     print $enum "};\n";
1815     $enum->close();
1816
1817     print $decl "static int hf_x11_glx_render_op_name = -1;\n\n";
1818
1819     print $impl "static const value_string glx_render_op_name"."[] = {\n";
1820     foreach my $req (sort {$a <=> $b} keys %request) {
1821         print $impl "    { $req, \"gl$request{$req}\" },\n";
1822     }
1823     print $impl "    { 0, NULL }\n";
1824     print $impl "};\n";
1825
1826     print $reg "{ &hf_x11_glx_render_op_name, { \"render op\", \"x11.glx.render.op\", FT_UINT16, BASE_DEC, VALS(glx_render_op_name), 0, NULL, HFILL }},\n\n";
1827
1828 # Uses ett_x11_list_of_rectangle, since I am unable to see how the subtree type matters.
1829     print $impl <<eot
1830
1831 static void dispatch_glx_render(tvbuff_t *tvb, packet_info *pinfo, int *offsetp, proto_tree *t, guint byte_order, int length)
1832 {
1833     while (length >= 4) {
1834         guint32 op, len;
1835         int next;
1836         proto_item *ti;
1837         proto_tree *tt;
1838
1839         len = VALUE16(tvb, *offsetp);
1840
1841         op = VALUE16(tvb, *offsetp + 2);
1842         ti = proto_tree_add_uint(t, hf_x11_glx_render_op_name, tvb, *offsetp, len, op);
1843
1844         tt = proto_item_add_subtree(ti, ett_x11_list_of_rectangle);
1845
1846         ti = proto_tree_add_item(tt, hf_x11_request_length, tvb, *offsetp, 2, byte_order);
1847         *offsetp += 2;
1848         proto_tree_add_item(tt, hf_x11_glx_render_op_name, tvb, *offsetp, 2, byte_order);
1849         *offsetp += 2;
1850
1851         if (len < 4) {
1852             expert_add_info(pinfo, ti, &ei_x11_request_length);
1853             /* Eat the rest of the packet, mark it undecoded */
1854             len = length;
1855             op = -1;
1856         }
1857         len -= 4;
1858
1859         next = *offsetp + len;
1860
1861         switch (op) {
1862 eot
1863     ;
1864     foreach my $req (sort {$a <=> $b} keys %request) {
1865         print $impl "\tcase $req:\n";
1866         print $impl "\t    mesa_$request{$req}(tvb, offsetp, tt, byte_order, len);\n";
1867         print $impl "\t    break;\n";
1868     }
1869     print $impl "\tdefault:\n";
1870     print $impl "\t    proto_tree_add_item(tt, hf_x11_undecoded, tvb, *offsetp, len, ENC_NA);\n";
1871     print $impl "\t    *offsetp += len;\n";
1872
1873     print $impl "\t}\n";
1874     print $impl "\tif (*offsetp < next) {\n";
1875     print $impl "\t    proto_tree_add_item(tt, hf_x11_unused, tvb, *offsetp, next - *offsetp, ENC_NA);\n";
1876     print $impl "\t    *offsetp = next;\n";
1877     print $impl "\t}\n";
1878     print $impl "\tlength -= (len + 4);\n";
1879     print $impl "    }\n}\n";
1880 }
1881
1882 $enum = new IO::File '> x11-enum.h'
1883         or die ("Cannot open x11-enum.h for writing\n");
1884 add_generated_header($enum, 'xcbproto');
1885 print $impl '#include "x11-enum.h"'."\n\n";
1886
1887 # XCB
1888 foreach my $ext (@reslist) {
1889     my $xml = XML::Twig->new(
1890                 start_tag_handlers => {
1891                     'xcb' => \&xcb_start,
1892                 },
1893                 twig_roots => {
1894                     'xcb' => \&xcb,
1895                     'import' => \&include,
1896                     'request' => \&request,
1897                     'struct' => \&struct,
1898                     'union' => \&union,
1899                     'xidtype' => \&xidtype,
1900                     'xidunion' => \&xidtype,
1901                     'typedef' => \&typedef,
1902                     'error' => \&error,
1903                     'errorcopy' => \&error,
1904                     'event' => \&event,
1905                     'enum' => \&enum,
1906                 });
1907     $xml->parsefile($ext) or die ("Cannot open $ext\n");
1908 }
1909
1910 print $impl "static void register_x11_extensions(void)\n{\n";
1911 foreach my $reg (@register) {
1912     print $impl "    register_$reg();\n";
1913 }
1914 print $impl "}\n";