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