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