lua-binding.pl

   1 #!/usr/bin/perl
   2
   3 # Known bugs:
   4 # - Does not support _checked or _unchecked variants of function calls
   5 # - Allows Lua to underflow and (maybe) crash C, when it should lua_error instead (so pcall can catch it)
   6 # - ChangeProperty is limited to the 8-bit datatype
   7
   8 # Known warts:
   9 # - Should get string lengths (and other lengths) from Lua, instead of requiring the length to be passed from the script
  10
  11 use warnings;
  12 use strict;
  13
  14 use XML::Simple qw(:strict);
  15
  16
  17 my %xcbtype = (
  18     BOOL => 'uint8_t',
  19     BYTE => 'uint8_t',
  20     CARD8 => 'uint8_t',
  21     CARD16 => 'uint16_t',
  22     CARD32 => 'uint32_t',
  23     INT8 => 'int8_t',
  24     INT16 => 'int16_t',
  25     INT32 => 'int32_t',
  26
  27     char => 'const char',
  28     void => 'const void',  # Hack, to partly support ChangeProperty, until we can reverse 'op'.
  29     float => 'float',
  30     double => 'double',
  31 );
  32
  33 my %luatype = (
  34     BOOL => 'boolean',
  35     BYTE => 'integer',
  36     CARD8 => 'integer',
  37     CARD16 => 'integer',
  38     CARD32 => 'integer',
  39     INT8 => 'integer',
  40     INT16 => 'integer',
  41     INT32 => 'integer',
  42
  43     char => 'integer',
  44     void => 'integer',  # Hack, to partly support ChangeProperty, until we can reverse 'op'.
  45     float => 'number',
  46     double => 'number',
  47 );
  48
  49 my %luachecktype = (
  50     BOOL => 'LUA_TBOOLEAN',
  51     BYTE => 'LUA_TNUMBER',
  52     CARD8 => 'LUA_TNUMBER',
  53     CARD16 => 'LUA_TNUMBER',
  54     CARD32 => 'LUA_TNUMBER',
  55     INT8 => 'LUA_TNUMBER',
  56     INT16 => 'LUA_TNUMBER',
  57     INT32 => 'LUA_TNUMBER',
  58
  59     char => 'LUA_TNUMBER',
  60     void => 'LUA_TNIL',
  61     float => 'LUA_TNUMBER',
  62     double => 'LUA_TNUMBER',
  63 );
  64
  65 sub mangle($;$)
  66 {
  67     my %simple = (
  68         CHAR2B => 1,
  69         INT64 => 1,
  70         FLOAT32 => 1,
  71         FLOAT64 => 1,
  72         BOOL32 => 1,
  73         STRING8 => 1,
  74         Family_DECnet => 1
  75     );
  76     my $name = shift;
  77     my $clean = shift;
  78     my $mangled = '';
  79
  80     $mangled = 'xcb_' unless ($clean);
  81
  82     if ($simple{$name}) {
  83         $mangled .= lc($name);
  84     } else {
  85         while (length ($name)) {
  86             $name =~ /^(.)(.*)$/;
  87             my $char = $1;
  88             my $next = $2;
  89
  90             $mangled .= lc($char);
  91
  92             if (
  93                 $name =~ /^[[:lower:]][[:upper:]]/ ||
  94                 $name =~ /^\d[[:alpha:]]/ ||
  95                 $name =~ /^[[:alpha:]]\d/ ||
  96                 $name =~ /^[[:upper:]][[:upper:]][[:lower:]]/)
  97             {
  98                 $mangled .= '_';
  99             }
 100
 101             $name = $next;
 102         }
 103     }
 104     return $mangled;
 105 }
 106
 107 sub cname($)
 108 {
 109     my %bad = (
 110         new => 1,
 111         delete => 1,
 112         class => 1,
 113         operator => 1 );
 114     my $name = shift;
 115     return "_$name" if ($bad{$name});
 116     return $name;
 117 }
 118
 119 sub do_push($$;$)
 120 {
 121     my $indent = ' ' x ((shift) * 4);
 122     my $type = shift;
 123     my $name = shift;
 124
 125     my $base;
 126
 127     if (defined($name)) {
 128         $base = "x->".cname($name);
 129     } else {
 130         $base = "i.data";
 131     }
 132
 133     if ($luatype{$type}) {
 134         # elemental type
 135         $base = '*'.$base if (!defined($name));
 136         print OUT $indent."lua_push".$luatype{$type}."(L, $base);\n";
 137     } else {
 138         # complex type
 139         $base = '&'.$base if (defined($name));
 140         print OUT $indent."push_$type(L, $base);\n";
 141     }
 142 }
 143
 144 sub do_push_list($$$$;$)
 145 {
 146     my $indent = shift;
 147     my $name = shift;
 148     my $type = shift;
 149     my $fn = shift;
 150     my $const = shift;
 151
 152     my $spaces = ' ' x (($indent) * 4);
 153     my $mtype = mangle($type);
 154
 155     if ($type eq 'char') {
 156         # String
 157         my $get = mangle($name)."_".$fn;
 158         print OUT $spaces."lua_pushlstring(L, ";
 159         print OUT "$get(x), ";
 160         print OUT $get."_length(x) );\n";
 161         print OUT $spaces."lua_setfield(L, -2, \"$fn\");\n";
 162     } elsif ($type eq 'void') {
 163         # Evil hack for GetProperty
 164         my $get = mangle($name)."_".$fn;
 165         print OUT $spaces."lua_pushlstring(L, ";
 166         print OUT "$get(x), ";
 167         print OUT $get."_length(x) * (x->format / 8) );\n";
 168         print OUT $spaces."lua_setfield(L, -2, \"$fn\");\n";
 169     } elsif (defined($luatype{$type})) {
 170         # Array of elemental type
 171         my $get = mangle($name)."_".$fn;
 172         print OUT $spaces."{\n";
 173         print OUT "$spaces    const ".$xcbtype{$type}." *i;\n";
 174         print OUT "$spaces    int len, j;\n\n";
 175         if (defined($const)) {
 176             my $cfn = cname($fn);
 177             my $len = $const->[0];
 178             print OUT "$spaces    i = x->$cfn;\n";
 179             print OUT "$spaces    len = $len;\n";
 180         } else {
 181             print OUT "$spaces    i = $get(x);\n";
 182             print OUT "$spaces    len = $get"."_length(x);\n";
 183         }
 184         print OUT "$spaces    lua_newtable(L);\n";
 185         print OUT "$spaces    for (j=0; j<len; j++) {\n";
 186         print OUT "$spaces        lua_push".$luatype{$type}."(L, i[j]);\n";
 187         print OUT "$spaces        lua_rawseti(L, -2, j+1);\n";
 188         print OUT "$spaces    }\n";
 189         print OUT "$spaces    lua_setfield(L, -2, \"$fn\");\n";
 190         print OUT "$spaces}\n";
 191     } else {
 192         # Array of complex type
 193         print OUT $spaces."{\n";
 194         print OUT "$spaces    $mtype"."_iterator_t i;\n";
 195         print OUT "$spaces    int j=0;\n\n";
 196         print OUT "$spaces    i = ".mangle($name)."_".$fn."_iterator(x);\n";
 197         print OUT "$spaces    lua_newtable(L);\n";
 198         print OUT "$spaces    while (i.rem) {\n";
 199         do_push($indent + 2, $type);
 200         print OUT "$spaces        lua_rawseti(L, -2, ++j);\n";
 201         print OUT "$spaces        $mtype"."_next(&i);\n";
 202         print OUT "$spaces    }\n";
 203         print OUT "$spaces    lua_setfield(L, -2, \"$fn\");\n";
 204         print OUT "$spaces}\n";
 205     }
 206 }
 207
 208 sub do_structs($)
 209 {
 210     my $xcb = shift;
 211     foreach my $struct (@{$xcb->{'struct'}}) {
 212         my $name = $struct->{'name'};
 213         my $xcbname = mangle($name).'_t';
 214         my $dogetter = 1;
 215
 216         my %nostatic = ( # These structs are used from the base protocol
 217             xcb_setup_t => 1,
 218         );
 219
 220         print OUT "static " unless ($nostatic{$xcbname});
 221
 222         print OUT "void push_$name (lua_State *L, const $xcbname *x)\n";
 223         print OUT "{\n";
 224         print OUT "    lua_newtable(L);\n";
 225         foreach my $field (@{$struct->{'field'}}) {
 226             my $fn = $field->{'name'};
 227             do_push(1, $field->{'type'}, $fn);
 228             print OUT "    lua_setfield(L, -2, \"$fn\");\n";
 229         }
 230         if ($struct->{'list'}) {
 231             $dogetter = 0;  # If it has a list, the get half shouldn't (can't?) be needed.
 232             foreach my $list (@{$struct->{'list'}}) {
 233                 do_push_list(1, $name, $list->{'type'}, $list->{'name'}, $list->{'value'});
 234             }
 235         }
 236         print OUT "}\n\n";
 237
 238         if ($dogetter) {
 239             print OUT "static void get_$name (lua_State *L, int pos, $xcbname *x)\n";
 240             print OUT "{\n";
 241             print OUT "    luaL_checktype(L, pos, LUA_TTABLE);\n";
 242             foreach my $field (@{$struct->{'field'}}) {
 243                 my $fn = $field->{'name'};
 244                 my $type = $luatype{$field->{'type'}};
 245                 my $checktype = $luachecktype{$field->{'type'}};
 246                 my $cfn = cname($fn);
 247                 print OUT "    lua_getfield(L, pos, \"$fn\");\n";
 248                 print OUT "    luaL_checktype(L, -1, $checktype);\n";
 249                 print OUT "    x->$cfn = lua_to$type(L, -1);\n";
 250                 print OUT "    lua_pop(L, 1);\n";
 251             }
 252             print OUT "}\n\n";
 253         }
 254     }
 255     foreach my $union (@{$xcb->{'union'}}) {
 256         my $name = $union->{'name'};
 257         my $xcbname = mangle($name).'_t';
 258
 259         print OUT "static ";
 260         print OUT "void push_$name (lua_State *L, const $xcbname *x)\n";
 261         print OUT "{\n";
 262         print OUT "    lua_newtable(L);\n";
 263         foreach my $field (@{$union->{'field'}}) {
 264             my $fn = $field->{'name'};
 265             do_push(1, $field->{'type'}, $fn);
 266             print OUT "    lua_setfield(L, -2, \"$fn\");\n";
 267         }
 268         if ($union->{'list'}) {
 269             foreach my $list (@{$union->{'list'}}) {
 270                 do_push_list(1, $name, $list->{'type'}, $list->{'name'}, $list->{'value'});
 271             }
 272         }
 273         print OUT "}\n\n";
 274     }
 275 }
 276
 277 sub do_typedefs($)
 278 {
 279     my $xcb = shift;
 280     foreach my $tdef (@{$xcb->{'typedef'}}) {
 281         $xcbtype{$tdef->{'newname'}} = $xcbtype{$tdef->{'oldname'}};
 282         $luatype{$tdef->{'newname'}} = $luatype{$tdef->{'oldname'}};
 283         $luachecktype{$tdef->{'newname'}} = $luachecktype{$tdef->{'oldname'}};
 284     }
 285     foreach my $tdef (@{$xcb->{'xidtype'}}) {
 286         $xcbtype{$tdef->{'name'}} = $xcbtype{'CARD32'};
 287         $luatype{$tdef->{'name'}} = $luatype{'CARD32'};
 288         $luachecktype{$tdef->{'name'}} = $luachecktype{'CARD32'};
 289     }
 290     foreach my $tdef (@{$xcb->{'xidunion'}}) {
 291         $xcbtype{$tdef->{'name'}} = $xcbtype{'CARD32'};
 292         $luatype{$tdef->{'name'}} = $luatype{'CARD32'};
 293         $luachecktype{$tdef->{'name'}} = $luachecktype{'CARD32'};
 294     }
 295 }
 296
 297 sub get_vartype($)
 298 {
 299     my $type = shift;
 300     return $xcbtype{$type} if (defined ($xcbtype{$type}));
 301     return mangle($type)."_t";
 302 }
 303
 304 sub do_get($$$;$)
 305 {
 306     my $index = shift;
 307     my $type = shift;
 308     my $name = shift;
 309     my $indent = shift;
 310
 311     $indent = 1 unless (defined($indent));
 312     $indent = ' ' x (($indent) * 4);
 313
 314     if ($luatype{$type}) {
 315         # elemental type
 316         print OUT $indent.$name." = lua_to".$luatype{$type}."(L, $index);\n";
 317     } else {
 318         # complex type
 319         print OUT $indent."get_$type(L, $index, &$name);\n";
 320     }
 321 }
 322
 323 sub do_get_list($$$;$)
 324 {
 325     my $index = shift;
 326     my $type = shift;
 327     my $name = shift;
 328     my $indent;
 329     my $autolen = shift;
 330
 331     $indent = 1 unless (defined($indent));
 332     my $spaces = ' ' x (($indent) * 4);
 333
 334     if ($type eq 'char' or $type eq 'void') {
 335         # Simple case: String
 336         print OUT $spaces.$name." = lua_tostring(L, $index);\n";
 337         return;
 338     }
 339
 340     print OUT $spaces."{\n";
 341     print OUT "$spaces    size_t i, count;\n";
 342     print OUT "$spaces    int idx = lua_gettop(L) + 1;\n";
 343     print OUT "$spaces    luaL_checktype(L, $index, LUA_TTABLE);\n";
 344     if ($autolen) {
 345         print OUT "$spaces    ${name}_len = lua_objlen(L, $index);\n";
 346         print OUT "$spaces    count = ${name}_len;\n";
 347     } else {
 348         print OUT "$spaces    count = lua_objlen(L, $index);\n";
 349     }
 350     print OUT "$spaces    $name = malloc(count * sizeof(";
 351
 352     if ($xcbtype{$type}) {
 353         # elemental type
 354         print OUT $xcbtype{$type};
 355     } else {
 356         # complex type
 357         print OUT mangle($type)."_t";
 358     }
 359     print OUT "));\n";
 360     print OUT "$spaces    for (i=0; i<count; i++) {\n";
 361     print OUT "$spaces        lua_rawgeti(L, $index, i+1);\n";
 362     do_get('idx', $type, $name.'[i]', $indent + 2);
 363     print OUT "$spaces        lua_pop(L, 1);\n";
 364     print OUT "$spaces    }\n";
 365
 366     print OUT $spaces."}";
 367 }
 368
 369 sub do_requests($\%)
 370 {
 371     my $xcb = shift;
 372     my $func = shift;
 373
 374     foreach my $req (@{$xcb->{'request'}}) {
 375         # Function header
 376         print OUT "static int ";
 377         print OUT $req->{'name'};
 378         print OUT "(lua_State *L)\n{\n";
 379
 380         my $cookie = mangle($req->{'name'})."_cookie_t";
 381
 382         # Declare variables
 383         if (defined($req->{'reply'})) {
 384             print OUT "    $cookie *cookie;\n";
 385         }
 386         print OUT "    xcb_connection_t *c;\n";
 387         foreach my $var (@{$req->{'field'}}) {
 388             print OUT "    ".get_vartype($var->{'type'})." ";
 389             print OUT $var->{'name'}.";\n";
 390         }
 391         if (defined($req->{'list'})) {
 392             foreach my $var (@{$req->{'list'}}) {
 393                 if (!defined($var->{'fieldref'}) && !defined($var->{'op'}) && !defined($var->{'value'})) {
 394                     print OUT "    uint32_t ";
 395                     print OUT $var->{'name'}."_len;\n";
 396                 }
 397                 print OUT "    ".get_vartype($var->{'type'})." *";
 398                 print OUT $var->{'name'}.";\n";
 399             }
 400         }
 401         if (defined($req->{'valueparam'})) {
 402             foreach my $var (@{$req->{'valueparam'}}) {
 403                 print OUT "    ".get_vartype($var->{'value-mask-type'})." ";
 404                 print OUT $var->{'value-mask-name'}.";\n";
 405                 print OUT "    uint32_t *".$var->{'value-list-name'}.";\n";
 406             }
 407         }
 408         print OUT "\n";
 409
 410         # Set up userdata
 411         if (defined($req->{'reply'})) {
 412             print OUT "    lua_newuserdata(L, sizeof(*cookie));\n";
 413             print OUT "    luaL_getmetatable(L, \"$cookie\");\n";
 414             print OUT "    lua_setmetatable(L, -2);\n";
 415             print OUT "    cookie = ($cookie *)lua_touserdata(L, -1);\n";
 416             print OUT "    lua_createtable(L, 0, 2);\n";
 417             print OUT "    lua_pushvalue(L, 1);\n";
 418             print OUT "    lua_setfield(L, -2, \"display\");\n";
 419             print OUT "    lua_pushboolean(L, 1);\n";
 420             print OUT "    lua_setfield(L, -2, \"collect\");\n";
 421             print OUT "    lua_setfenv(L, -2);\n\n";
 422         }
 423
 424         # Read variables from lua
 425         print OUT "    c = ((xcb_connection_t **)luaL_checkudata(L, 1, \"XCB.display\"))[0];\n";
 426         my $index = 1;
 427         foreach my $var (@{$req->{'field'}}) {
 428             do_get(++$index, $var->{'type'}, $var->{'name'});
 429         }
 430         if (defined($req->{'list'})) {
 431             foreach my $var (@{$req->{'list'}}) {
 432                 if (!defined($var->{'fieldref'}) && !defined($var->{'op'}) && !defined($var->{'value'})) {
 433                     # do_get(++$index, 'CARD32', $var->{'name'}."_len");
 434                     do_get_list(++$index, $var->{'type'}, $var->{'name'}, 1);
 435                 } else {
 436                     do_get_list(++$index, $var->{'type'}, $var->{'name'});
 437                 }
 438             }
 439         }
 440         if (defined($req->{'valueparam'})) {
 441             foreach my $var (@{$req->{'valueparam'}}) {
 442                 do_get(++$index, $var->{'value-mask-type'}, $var->{'value-mask-name'});
 443                 do_get_list(++$index, 'CARD32', $var->{'value-list-name'});
 444             }
 445         }
 446         print OUT "\n";
 447
 448         # Function call
 449         print OUT "    ";
 450         if (defined($req->{'reply'})) {
 451             print OUT "*cookie = ";
 452         }
 453         print OUT mangle($req->{'name'})."(";
 454         my $glob = 'c, ';
 455         foreach my $var (@{$req->{'field'}}) {
 456             $glob .= $var->{'name'};
 457             $glob .= ", ";
 458         }
 459         if (defined($req->{'list'})) {
 460             foreach my $var (@{$req->{'list'}}) {
 461                 if (!defined($var->{'fieldref'}) && !defined($var->{'op'}) && !defined($var->{'value'})) {
 462                     $glob .= $var->{'name'}.'_len';
 463                     $glob .= ", ";
 464                 }
 465                 $glob .= $var->{'name'};
 466                 $glob .= ", ";
 467             }
 468         }
 469         if (defined($req->{'valueparam'})) {
 470             foreach my $var (@{$req->{'valueparam'}}) {
 471                 $glob .= $var->{'value-mask-name'};
 472                 $glob .= ", ";
 473                 $glob .= $var->{'value-list-name'};
 474                 $glob .= ", ";
 475             }
 476         }
 477         chop $glob; chop $glob;  # removing trailing comma
 478         print OUT "$glob);\n\n";
 479
 480         # Cleanup
 481         if (defined($req->{'list'})) {
 482             foreach my $var (@{$req->{'list'}}) {
 483                 if ($var->{'type'} ne 'char' and $var->{'type'} ne 'void') {
 484                     print OUT "    free(". $var->{'name'}.");\n";
 485                 }
 486             }
 487         }
 488
 489         if (defined($req->{'valueparam'})) {
 490             foreach my $var (@{$req->{'valueparam'}}) {
 491                 print OUT "    free(". $var->{'value-list-name'}.");\n";
 492             }
 493         }
 494
 495         my $retcount = 0;
 496         $retcount = 1 if (defined($req->{'reply'}));
 497         print OUT "    return $retcount;\n}\n\n";
 498
 499         my $manglefunc = mangle($req->{'name'}, 1);
 500         $func->{$manglefunc} = $req->{'name'};
 501     }
 502 }
 503
 504 sub do_events($)
 505 {
 506     my $xcb = shift;
 507     my %events;
 508
 509     foreach my $event (@{$xcb->{'event'}}) {
 510         my $xcbev = mangle($event->{'name'})."_event_t";
 511         print OUT "/* This function adds the remaining fields into the table\n  that is on the top of the stack */\n";
 512         print OUT "static void set_";
 513         print OUT $event->{'name'};
 514         print OUT "(lua_State *L, xcb_generic_event_t *event)\n{\n";
 515         print OUT "    $xcbev *x = ($xcbev *)event;\n";
 516         foreach my $var (@{$event->{'field'}}) {
 517             my $name = $var->{'name'};
 518             do_push(1, $var->{'type'}, $name);
 519             print OUT "    lua_setfield(L, -2, \"$name\");\n";
 520         }
 521         print OUT "}\n\n";
 522         $events{$event->{'number'}} = 'set_'.$event->{'name'};
 523     }
 524
 525     foreach my $event (@{$xcb->{'eventcopy'}}) {
 526         $events{$event->{'number'}} = 'set_'.$event->{'ref'};
 527     }
 528
 529     print OUT "static void init_events()\n{\n";
 530     foreach my $i (sort { $a <=> $b } keys %events) {
 531         print OUT "    RegisterEvent($i, $events{$i});\n";
 532     }
 533     print OUT "}\n\n";
 534 }
 535
 536 sub do_replies($\%\%)
 537 {
 538     my $xcb = shift;
 539     my $func = shift;
 540     my $collect = shift;
 541
 542     foreach my $req (@{$xcb->{'request'}}) {
 543         my $rep = $req->{'reply'};
 544         next unless defined($rep);
 545
 546         my $name = mangle($req->{'name'});
 547         my $cookie = $name."_cookie_t";
 548
 549         $collect->{$cookie} = $req->{'name'}."_gc";
 550
 551         # Garbage collection function
 552         print OUT "static int ";
 553         print OUT $req->{'name'}.'_gc';
 554         print OUT "(lua_State *L)\n{\n";
 555         print OUT "    $cookie *cookie = ($cookie *)luaL_checkudata(L, 1, \"$cookie\");\n";
 556         print OUT "    lua_getfenv(L, 1);\n";
 557         print OUT "    lua_getfield(L, -1, \"collect\");\n";
 558         print OUT "    if (lua_toboolean(L, -1)) {\n";
 559         print OUT "        xcb_connection_t *c;\n";
 560         print OUT "        xcb_generic_error_t *e = NULL;\n";
 561         print OUT "        $name"."_reply_t *x = NULL;\n";
 562         print OUT "        lua_getfield(L, -2, \"display\");\n";
 563         print OUT "        c = ((xcb_connection_t **)luaL_checkudata(L, -1, \"XCB.display\"))[0];\n\n";
 564
 565         print OUT "        lua_getfenv(L, -1);\n";
 566         print OUT "        lua_getfield(L, -1, \"closed\");\n";
 567         print OUT "        if (!lua_toboolean(L, -1))\n";
 568         print OUT "            x = $name"."_reply(c, *cookie, &e);\n\n";
 569
 570         print OUT "        if (x) free(x);\n";
 571                 # TODO: Needs a way to report errors in GC'd replies
 572         print OUT "        if (e) free(e);\n";
 573         print OUT "    }\n";
 574         print OUT "    return 0;\n";
 575         print OUT "}\n\n";
 576
 577         # Function header
 578         print OUT "static int ";
 579         print OUT $req->{'name'}.'_reply';
 580         print OUT "(lua_State *L)\n{\n";
 581
 582         # Declare variables
 583         print OUT "    xcb_connection_t *c;\n";
 584         print OUT "    xcb_generic_error_t *e = NULL;\n";
 585         print OUT "    $name"."_reply_t *x;\n";
 586         print OUT "    $cookie *cookie;\n";
 587         print OUT "\n";
 588
 589         # Read variables from lua
 590         print OUT "    c = ((xcb_connection_t **)luaL_checkudata(L, 1, \"XCB.display\"))[0];\n";
 591         print OUT "    lua_getfenv(L, 1);\n";
 592         print OUT "    lua_getfield(L, -1, \"closed\");\n";
 593         print OUT "    if (lua_toboolean(L, -1))\n";
 594         print OUT "        luaL_error(L, \"Error: already disconnected\");\n";
 595         print OUT "    lua_pop(L, 2);\n\n";
 596
 597         print OUT "    cookie = ($cookie *)luaL_checkudata(L, 2, \"$cookie\");\n";
 598         print OUT "\n";
 599
 600         # Function call
 601         print OUT "    x = $name"."_reply(c, *cookie, &e);\n\n";
 602
 603         # Mark reply as not collectable
 604         print OUT "    lua_getfenv(L, 2);\n";
 605         print OUT "    lua_getfield(L, -1, \"collect\");\n";
 606         print OUT "    if (!lua_toboolean(L, -1)) {\n";
 607         print OUT "        luaL_error(L, \"Error: Attempted to wait for the same %s cookie twice\", \"$name\");\n";
 608         print OUT "    }\n";
 609         print OUT "    lua_pushboolean(L, 0);\n";
 610         print OUT "    lua_setfield(L, -3, \"collect\");\n";
 611         print OUT "    lua_pop(L, 2);\n\n";
 612
 613         # Push reply to lua
 614         print OUT "    if (x) {\n";
 615         print OUT "        lua_newtable(L);\n";
 616         foreach my $var (@{$rep->[0]->{'field'}}) {
 617             my $name = $var->{'name'};
 618             do_push(2, $var->{'type'}, $name);
 619             print OUT "        lua_setfield(L, -2, \"$name\");\n";
 620         }
 621         if (defined $rep->[0]->{'list'}) {
 622             foreach my $list (@{$rep->[0]->{'list'}}) {
 623                 do_push_list(2, $req->{'name'}, $list->{'type'}, $list->{'name'}, $list->{'value'});
 624             }
 625         }
 626
 627         print OUT "        free(x);\n";
 628         print OUT "    } else\n";
 629         print OUT "        lua_pushnil(L);\n\n";
 630
 631         print OUT "    if (e) {\n";
 632         print OUT "        push_ERROR(L, e);\n";
 633         print OUT "        free(e);\n";
 634         print OUT "    } else\n";
 635         print OUT "        lua_pushnil(L);\n\n";
 636
 637         print OUT "    return 2;\n}\n\n";
 638
 639         my $manglefunc = mangle($req->{'name'}, 1);
 640         $func->{$manglefunc.'_reply'} = $req->{'name'}.'_reply';
 641     }
 642 }
 643
 644 sub do_enums($)
 645 {
 646     my $xcb = shift;
 647
 648     print OUT "/* This function adds enums into the table that is on the top of the stack */\n";
 649     print OUT "static void set_enums(lua_State *L)\n{\n";
 650
 651     foreach my $enum (@{$xcb->{'enum'}}) {
 652         print OUT "    lua_newtable(L);\n";
 653         foreach my $item (@{$enum->{'item'}}) {
 654             my $value = $item->{'value'};
 655             my $bit = $item->{'bit'};
 656             if ($value) {
 657                 print OUT "    lua_pushinteger(L, $value->[0]);\n";
 658             } elsif ($bit) {
 659                 print OUT "    lua_pushinteger(L, 1u << $bit->[0]);\n";
 660             } else {
 661                 die ("Unexpected enum type on ".$item->{'name'}."\n");
 662             }
 663
 664             my $name = mangle($item->{'name'}, 1);
 665             $name = uc($name);
 666             print OUT "    lua_setfield(L, -2, \"$name\");\n";
 667         }
 668         my $name = mangle($enum->{'name'}, 1);
 669         $name = uc($name);
 670         print OUT "    lua_setfield(L, -2, \"$name\");\n";
 671     }
 672
 673     # Events
 674     print OUT "\n    lua_newtable(L);\n";
 675     foreach my $event (@{$xcb->{'event'}}) {
 676         my $name = $event->{'name'};
 677         my $number = $event->{'number'};
 678         print OUT "    lua_pushinteger(L, $number);\n";
 679         print OUT "    lua_setfield(L, -2, \"$name\");\n";
 680     }
 681
 682     foreach my $event (@{$xcb->{'eventcopy'}}) {
 683         my $name = $event->{'name'};
 684         my $number = $event->{'number'};
 685         print OUT "    lua_pushinteger(L, $number);\n";
 686         print OUT "    lua_setfield(L, -2, \"$name\");\n";
 687     }
 688     print OUT "    lua_setfield(L, -2, \"event\");\n";
 689
 690     # Errors
 691     print OUT "\n    lua_newtable(L);\n";
 692     foreach my $error (@{$xcb->{'error'}}) {
 693         my $name = $error->{'name'};
 694         my $number = $error->{'number'};
 695         print OUT "    lua_pushinteger(L, $number);\n";
 696         print OUT "    lua_setfield(L, -2, \"$name\");\n";
 697     }
 698
 699     foreach my $error (@{$xcb->{'errorcopy'}}) {
 700         my $name = $error->{'name'};
 701         my $number = $error->{'number'};
 702         print OUT "    lua_pushinteger(L, $number);\n";
 703         print OUT "    lua_setfield(L, -2, \"$name\");\n";
 704     }
 705     print OUT "    lua_setfield(L, -2, \"error\");\n";
 706
 707     print OUT "}\n\n";
 708 }
 709
 710 sub do_gcs($\%)
 711 {
 712     my $xcb = shift;
 713     my $collect = shift;
 714
 715     print OUT "static void init_gcs(lua_State *L)\n{\n";
 716     foreach my $cookie (keys(%$collect)) {
 717         my $func = $collect->{$cookie};
 718         print OUT "    luaL_newmetatable(L, \"$cookie\");\n";
 719         print OUT "    lua_pushcfunction(L, $func);\n";
 720         print OUT "    lua_setfield(L, -2, \"__gc\");\n";
 721         print OUT "    lua_pop(L, 1);\n";
 722     }
 723     print OUT "}\n\n";
 724 }
 725
 726 sub do_init($\%)
 727 {
 728     my $xcb = shift;
 729     my $func = shift;
 730
 731     print OUT "/* This function adds function calls into the table\n   that is on the top of the stack */\n";
 732     print OUT "void init_".$xcb->{'header'}."(lua_State *L)\n{\n";
 733     print OUT "    init_events(L);\n";
 734     print OUT "    init_gcs(L);\n";
 735     print OUT "    set_enums(L);\n";
 736     foreach my $name (keys %{$func}) {
 737         my $funcname = $func->{$name};
 738         print OUT "    lua_pushcfunction(L, $funcname);\n";
 739         print OUT "    lua_setfield(L, -2, \"$name\");\n";
 740     }
 741     print OUT "}\n";
 742 }
 743
 744
 745 my @files;
 746
 747 opendir(DIR, '.');
 748 @files = grep { /\.xml$/ } readdir(DIR);
 749 closedir DIR;
 750
 751 foreach my $name (@files) {
 752     $name =~ s/\.xml$//;
 753
 754     my $xcb = XMLin("$name.xml", KeyAttr => undef, ForceArray => 1);
 755
 756     open(OUT, ">$name.c") or die ("Cannot open $name.c for writing");
 757
 758 print OUT <<eot
 759 /*
 760  * This file generated automatically from $name.xml by lua-binding.pl
 761  * Edit at your peril.
 762  */
 763
 764 #include <string.h>
 765 #include <stdlib.h>
 766
 767 #include <lua5.1/lua.h>
 768 #include <lua5.1/lauxlib.h>
 769
 770 #include <xcb/xcb.h>
 771 #include <xcb/xcbext.h>
 772 #include <xcb/$name.h>
 773
 774 typedef void (*eventFunc)(lua_State *L, xcb_generic_event_t *);
 775 extern void RegisterEvent(int index, eventFunc func);
 776
 777 void push_ERROR(lua_State *L, xcb_generic_error_t *e)
 778 {
 779     xcb_value_error_t *ve = (xcb_value_error_t *)e;
 780     lua_newtable(L);
 781
 782     lua_pushinteger(L, ve->response_type);
 783     lua_setfield(L, -2, "response_type");
 784     lua_pushinteger(L, ve->error_code);
 785     lua_setfield(L, -2, "error_code");
 786     lua_pushinteger(L, ve->sequence);
 787     lua_setfield(L, -2, "sequence");
 788     lua_pushinteger(L, ve->bad_value);
 789     lua_setfield(L, -2, "bad_value");
 790     lua_pushinteger(L, ve->minor_opcode);
 791     lua_setfield(L, -2, "minor_opcode");
 792     lua_pushinteger(L, ve->major_opcode);
 793     lua_setfield(L, -2, "major_opcode");
 794
 795     lua_pushinteger(L, e->full_sequence);
 796     lua_setfield(L, -2, "full_sequence");
 797 }
 798
 799 eot
 800     ;
 801
 802     my %functions;
 803     my %collectors;
 804     do_typedefs($xcb);
 805     do_structs($xcb);
 806     do_events($xcb);
 807     do_requests($xcb, %functions);
 808     do_replies($xcb, %functions, %collectors);
 809     do_enums($xcb);
 810     do_gcs($xcb, %collectors);
 811     do_init($xcb, %functions);
 812     close OUT;
 813 }