1#!/usr/bin/env perl 2# vim:ts=4:sw=4:expandtab 3 4# Known bugs: 5# - Does not support _checked or _unchecked variants of function calls 6# - Allows Lua to underflow and (maybe) crash C, when it should lua_error instead (so pcall can catch it) 7# - ChangeProperty is limited to the 8-bit datatype 8 9# Known warts: 10# - Should get string lengths (and other lengths) from Lua, instead of requiring the length to be passed from the script 11 12package _GenerateMyXS; 13 14use strict; use warnings; use v5.10; 15use autodie; 16use Data::Dump; 17use List::Util qw(first); 18use ExtUtils::PkgConfig; 19 20use XML::Simple qw(:strict); 21 22use XML::Descent; 23my $parser; 24 25# forward declarations of utility functions: 26sub on; sub walk; # parser 27sub slurp; sub spit; # file reading/writing 28# name mangeling: 29sub decamelize($); sub xcb_name($); sub xcb_type($); sub perl_name($); sub cname($); 30 31sub indent (&$@); # templating 32our $indent_level = 1; 33 34my $prefix = 'xcb_'; 35my %const; 36 37# The tmpl_* function push their generated code onto those arrays, 38# &generate in turn writes and empties them. 39my (@struct, @request); 40 41# XXX currently unused: 42# In contrary to %xcbtype, which only holds basic data types like 'int', 'char' 43# and so on, the %exacttype hash holds the real type name, like INT16 or CARD32 44# for any type which has been specified in the XML definition. For example, 45# type KEYCODE is an alias for CARD32. This is necessary later on to correctly 46# typecast our intArray type. 47my %exacttype = (); 48 49my %xcbtype = ( 50 BOOL => 'int', 51 BYTE => 'uint8_t', 52 CARD8 => 'uint8_t', 53 CARD16 => 'uint16_t', 54 CARD32 => 'uint32_t', 55 INT8 => 'uint8_t', 56 INT16 => 'uint16_t', 57 INT32 => 'uint32_t', 58 59 char => 'char', 60 void => 'void', # Hack, to partly support ChangeProperty, until we can reverse 'op'. 61 float => 'double', 62 double => 'double', 63); 64 65sub tmpl_struct { 66 my ($name, $params, $types) = @_; 67 68 my $constructor = 'new'; 69 70 my $param = join ',', @$params; 71 my $param_decl = indent { "$types->{$_} $_" } "\n", @$params; 72 my $set_struct = indent { 'buf->' . cname($_) . " = $_;" } "\n", @$params; 73 74 push @struct, << "__" 75MODULE = X11::XCB PACKAGE = $name 76$name * 77$constructor(self,$param) 78 char *self 79$param_decl 80 PREINIT: 81 $name *buf; 82 CODE: 83 New(0, buf, 1, $name); 84$set_struct 85 RETVAL = buf; 86 OUTPUT: 87 RETVAL 88 89__ 90} 91 92sub tmpl_struct_getter { 93 my ($pkg, $name, $type) = @_; 94 my $cname = cname($name); 95 96 push @struct, << "__" 97MODULE = X11::XCB PACKAGE = ${pkg}Ptr 98 99$type 100$name(self) 101 $pkg * self 102 CODE: 103 RETVAL = self->$cname; 104 OUTPUT: 105 RETVAL 106 107__ 108} 109 110sub tmpl_request { 111 my ($name, $cookie, $params, $types, $xcb_cast, $cleanups) = @_; 112 113 my $param = join ',', ('conn', @$params); 114 my @param = grep { $_ ne '...' } @$params; 115 116 my $param_decl = indent { "$types->{$_} $_" } "\n", @param; 117 118 # XXX should be "$prefix$name", but $name has already a prefix like xinerama_ 119 my $xcb_name = "xcb_$name"; 120 my $xcb_param = do { 121 local $indent_level = 0; 122 $xcb_cast->{conn} = ''; 123 indent { $xcb_cast->{$_} . $_ } ', ', ('conn', @param); 124 }; 125 my $cleanup = indent { "free($_);" } "\n", @$cleanups; 126 127 push @request, << "__" 128HV * 129$name($param) 130 XCBConnection *conn 131$param_decl 132 PREINIT: 133 HV * hash; 134 $cookie cookie; 135 CODE: 136 cookie = $xcb_name($xcb_param); 137 138 hash = newHV(); 139 hv_store(hash, "sequence", strlen("sequence"), newSViv(cookie.sequence), 0); 140 RETVAL = hash; 141$cleanup 142 OUTPUT: 143 RETVAL 144 145__ 146} 147 148sub on_field { 149 my ($fields, $types) = @_; 150 151 on field => sub { 152 my $name = $_->{name}; 153 push @$fields, $name; 154 155 my $type = xcb_type($_->{type}); 156 # XXX why not XCB\u$1? 157 $type =~ s/^xcb_/XCB/; 158 $types->{$name} = $type; 159 } 160} 161 162sub do_structs { 163 my $x_name = $_->{name}; 164 my $xcb_type = xcb_type $x_name; 165 my $perlname = perl_name $x_name; 166 167 print OUTTD " typedef $xcb_type $perlname;\n"; 168 print OUTTM "$perlname * T_PTROBJ\n"; 169 170 my (@fields, %type); 171 on_field(\@fields, \%type); 172 173 my $dogetter = 1; 174 175 my %nostatic = ( # These structs are used from the base protocol 176 xcb_setup_t => 1, 177 ); 178 179 # TODO: unimplemented 180 on list => sub { 181 $dogetter = 0; # If it has a list, the get half shouldn't (can't?) be needed. 182 }; 183 184 # TODO: unimplemented 185 # on union => sub { on [ qw/field list/ ] => sub {} }; 186 187 walk; 188 189 tmpl_struct($perlname, \@fields, \%type); 190 191 if ($dogetter) { 192 tmpl_struct_getter($perlname, $_, $type{$_}) for @fields; 193 } 194 195} 196 197sub do_typedefs { 198 my $e = shift; 199 200 if ($e eq 'typedef') { 201 $xcbtype{ $_->{newname} } = $xcbtype{ $_->{oldname} }; 202 $exacttype{ $_->{newname} } = $_->{oldname}; 203 } 204 elsif ($e =~ /^(?:xidtype|xidunion)/) { 205 $xcbtype{ $_->{name} } = $xcbtype{CARD32}; 206 } 207} 208 209# items is already in use by XS, see perlapi 210# <Variables created by "xsubpp" and "xsubpp" internal functions> for more 211# XXX this is currently only used in do_request/on list 212sub param_sanitize { 213 $_[0] eq 'items' ? 'items_' : $_[0] 214} 215 216sub do_requests { 217 my $x_name = $_->{name}; 218 my $xcb_name = xcb_name $x_name; 219 220 # XXX hack, to get eg. a xinerama_ prefix 221 (my $ns = $prefix) =~ s/^xcb_//; 222 223 my $name = $ns . decamelize $x_name; 224 225 my (@param, %type, %xcb_cast, @cleanup); 226 227 # Skip documentation blocks. 228 on doc => sub {}; 229 230 on_field(\@param, \%type); 231 232 # array length 233 # TODO : rid _len from parameters, use XS to get the length of strings, etc 234 on list => sub { 235 my $param = param_sanitize($_->{name}); 236 my $x_type = $_->{type}; 237 238 my $push_len = 1; 239 on [ qw/fieldref op value/ ] => sub { $push_len = 0 }; 240 walk; 241 242 push @param, $param . '_len' if $push_len; 243 push @param, $param; 244 245 my $type = $xcbtype{$x_type} || perl_name $x_type; 246 247 if ($type =~ /^uint(?:8|16|32)_t$/) { 248 $xcb_cast{$param} = " (const $type*)"; 249 $type = 'intArray' 250 } 251 252 # We use char* instead of void* to be able to use pack() in the perl part 253 $type = 'char' if $type eq 'void'; 254 255 $type{$param} = "$type *"; 256 $type{$param . '_len'} = 'int' if $push_len; 257 258 push @cleanup, $param unless $type =~ /^(?:char|void)$/; 259 }; 260 261 # bitmask -> list of value. 262 # TODO: ideally this would be a hashref eg. C< { bitname => "value", … } > 263 on valueparam => sub { 264 my ($mask, $list, $type) = @{$_}{qw/value-mask-name value-list-name value-mask-type/}; 265 push @param, $mask 266 # eg. ConfigureWindow already specifies the mask via <field /> 267 unless ($param[-1] || '') eq $mask; 268 269 push @param, $list; 270 push @param, '...'; 271 272 $type{$mask} = xcb_type $type; 273 $type{$list} = 'intArray *'; 274 275 push @cleanup, $list; 276 }; 277 278 on switch => sub { 279 my ($elem, $attr, $ctx) = @_; 280 my $mask = 'value_mask'; 281 my $list = $attr->{'name'}; 282 push @param, $mask 283 # eg. ConfigureWindow already specifies the mask via <field /> 284 unless ($param[-1] || '') eq $mask; 285 286 push @param, $list; 287 push @param, '...'; 288 289 $type{$list} = 'intArray *'; 290 291 push @cleanup, $list; 292 }; 293 294 my $cookie = 'xcb_void_cookie_t'; 295 on reply => sub { $cookie = $xcb_name . '_cookie_t'; 'do_reply(@_)' }; 296 walk; 297 298 $xcb_cast{$_} ||= '' for @param; 299 300 tmpl_request($name, $cookie, \@param, \%type, \%xcb_cast, \@cleanup); 301 302} 303 304sub do_events($) { 305 my $xcb = shift; 306 my %events; 307 308 # TODO: events 309} 310 311sub do_replies($\%\%) { 312 my ($xcb, $func, $collect) = @_; 313 314 for my $req (@{ $xcb->{request} }) { 315 my $rep = $req->{reply}; 316 next unless defined($rep); 317 # request should return a cookie object, blessed into the right pkg 318 # $perlname should be set fixed to 'reply' 319 320 my $name = xcb_name($req->{name}) . "_reply"; 321 my $reply = xcb_name($req->{name}) . "_reply_t"; 322 my $perlname = $name; 323 $perlname =~ s/^xcb_//g; 324 my $cookie = xcb_name($req->{name}) . "_cookie_t"; 325 326 print OUT "HV *\n$perlname(conn,sequence)\n"; 327 print OUT " XCBConnection *conn\n"; 328 print OUT " int sequence\n"; 329 print OUT " PREINIT:\n"; 330 print OUT " HV * hash;\n"; 331 print OUT " HV * inner_hash;\n"; 332 print OUT " AV * alist;\n"; 333 print OUT " int c;\n"; 334 print OUT " int _len;\n"; 335 print OUT " $cookie cookie;\n"; 336 print OUT " $reply *reply;\n"; 337 print OUT " CODE:\n"; 338 print OUT " cookie.sequence = sequence;\n"; 339 print OUT " reply = $name(conn, cookie, NULL);\n"; 340 # XXX use connection_has_error 341 print OUT qq/ if (!reply) croak("Could not get reply for: $name"); /; 342 print OUT " hash = newHV();\n"; 343 344 # We ignore pad0 and response_type. Every reply has sequence and length 345 print OUT " hv_store(hash, \"sequence\", strlen(\"sequence\"), newSViv(reply->sequence), 0);\n"; 346 print OUT " hv_store(hash, \"length\", strlen(\"length\"), newSViv(reply->length), 0);\n"; 347 for my $var (@{ $rep->[0]->{field} }) { 348 my $type = xcb_type($var->{type}); 349 my $name = cname($var->{name}); 350 if ($type =~ /^(?:uint(?:8|16|32)_t|int)$/) { 351 print OUT " hv_store(hash, \"$name\", strlen(\"$name\"), newSViv(reply->$name), 0);\n"; 352 } else { 353 print OUT " /* TODO: type $type, name $var->{name} */\n"; 354 } 355 } 356 357 for my $list (@{ $rep->[0]->{list} }) { 358 my $listname = $list->{name}; 359 my $type = xcb_name($list->{type}) . '_t'; 360 my $iterator = xcb_name($list->{type}) . '_iterator_t'; 361 my $iterator_next = xcb_name($list->{type}) . '_next'; 362 my $pre = xcb_name($req->{name}); 363 364 if ($list->{type} eq 'void') { 365 366 # A byte-array. Provide it as SV. 367 print OUT " _len = reply->value_len * (reply->format / 8);\n"; 368 print OUT " if (_len > 0)\n"; 369 print OUT " hv_store(hash, \"value\", strlen(\"value\"), newSVpvn((const char*)(reply + 1), _len), 0);\n"; 370 next; 371 } 372 373 # Get the type description of the list’s members 374 my $struct = first { $_->{name} eq $list->{type} } @{ $xcb->{struct} }; 375 376 next unless defined($struct->{field}) && scalar(@{ $struct->{field} }) > 0; 377 378 print OUT " {\n"; 379 print OUT " /* Handling list part of the reply */\n"; 380 print OUT " alist = newAV();\n"; 381 print OUT " $iterator iterator = $pre" . '_' . $listname . "_iterator(reply);\n"; 382 print OUT " for (; iterator.rem > 0; $iterator_next(&iterator)) {\n"; 383 print OUT " $type *data = iterator.data;\n"; 384 print OUT " inner_hash = newHV();\n"; 385 386 for my $field (@{ $struct->{field} }) { 387 my $type = xcb_type($field->{type}); 388 my $name = cname($field->{name}); 389 390 if ($type =~ /^(?:uint(?:8|16|32)_t|int)$/) { 391 print OUT " hv_store(inner_hash, \"$name\", strlen(\"$name\"), newSViv(data->$name), 0);\n"; 392 } else { 393 print OUT " /* TODO: type $type, name $name */\n"; 394 } 395 } 396 print OUT " av_push(alist, newRV((SV*)inner_hash));\n"; 397 398 print OUT " }\n"; 399 print OUT " hv_store(hash, \"" . $list->{name} . "\", strlen(\"" . $list->{name} . "\"), newRV((SV*)alist), 0);\n"; 400 401 print OUT " }\n"; 402 } 403 404 #print Dumper($rep); 405 #if (defined($rep->{list})) { 406 407 print OUT " RETVAL = hash;\n"; 408 print OUT " OUTPUT:\n RETVAL\n\n"; 409 } 410} 411 412sub do_enums { 413 my ($tag, $attr) = @_; 414 415 my $name = uc decamelize $attr->{name}; 416 417 if ($tag eq 'enum') { 418 on item => sub { 419 my $tname = $name . "_" . uc decamelize $_->{name}; 420 $const{$tname} = "newSViv(XCB_$tname)"; 421 }; 422 walk; 423 424 } 425 elsif ($tag eq 'event') { # =~ /^(?:event|eventcopy|error|errorcopy)$/) { 426 $const{$name} = "newSViv(XCB_$name)"; 427 } 428 429} 430 431sub generate { 432 my $path = ExtUtils::PkgConfig->variable('xcb-proto', 'xcbincludedir'); 433 my @xcb_xmls = qw/xproto.xml xinerama.xml/; 434 435 -d $path or die "$path: $!\n"; 436 437 # TODO: Handle all .xmls 438 #opendir(DIR, '.'); 439 #@files = grep { /\.xml$/ } readdir(DIR); 440 #closedir DIR; 441 442 my @files = map { 443 my $xml = "$path/$_"; 444 -r $xml or die "$xml: $!\n"; 445 $xml 446 } @xcb_xmls; 447 448 open(OUT, ">XCB_xs.inc"); 449 open(OUTTM, ">typemap"); 450 open(OUTTD, ">typedefs.h"); 451 452 print OUTTM << '__'; 453XCBConnection * T_PTROBJ_MG 454intArray * T_ARRAY 455X11_XCB_ICCCM_WMHints * T_PTROBJ 456X11_XCB_ICCCM_SizeHints * T_PTROBJ 457uint8_t T_U_CHAR 458uint16_t T_U_SHORT 459uint32_t T_UV 460__ 461 462 463 464 # Our own additions: EWMH constants 465 $const{_NET_WM_STATE_ADD} = 'newSViv(1)'; 466 $const{_NET_WM_STATE_REMOVE} = 'newSViv(0)'; 467 $const{_NET_WM_STATE_TOGGLE} = 'newSViv(2)'; 468 469 # ICCCM constants from xcb-util 470 for my $const (qw(XCB_ICCCM_WM_STATE_WITHDRAWN XCB_ICCCM_WM_STATE_NORMAL XCB_ICCCM_WM_STATE_ICONIC)) { 471 my ($name) = ($const =~ /XCB_(.*)/); 472 $const{$name} = "newSViv($const)"; 473 } 474 475 for my $path (@files) { 476 say "Processing: $path"; 477 my $xcb = XMLin("$path", KeyAttr => undef, ForceArray => 1); 478 479 $parser = XML::Descent->new({ Input => $path }); 480 481 on xcb => sub { 482 my ($e, $attr) = @_; 483 my $name = $attr->{header}; 484 485 $prefix = $name eq 'xproto' ? 'xcb_' : "xcb_${name}_"; 486 487 on [ qw/enum event eventcopy error errorcopy/ ] => \&do_enums; 488 on [ qw/typedef xidtype xidunion/ ] => \&do_typedefs; 489 on struct => \&do_structs; 490 on request => \&do_requests; 491 walk; 492 }; 493 walk; 494 495 print OUT @struct; 496 undef @struct; 497 498 do_events($xcb); 499 500 print OUT "MODULE = X11::XCB PACKAGE = X11::XCB\n"; 501 print OUT @request; 502 undef @request; 503 504 &do_replies($xcb); 505 506 507 } 508 509 close OUT; 510 close OUTTM; 511 close OUTTD; 512 513 my @const = sort keys %const; 514 515 spit 'XCB.inc', << "__", 516static void boot_constants(HV *stash, AV *tags_all) { 517 av_extend(tags_all, ${\ scalar @const }); 518__ 519 (map { << "__" } @const), 520 newCONSTSUB(stash, "$_", $const{$_}); 521 av_push(tags_all, newSVpvn("$_", ${\ length $_ })); 522__ 523 "}\n"; 524} 525 526# utility functions 527 528sub on { 529 my ($tag, $code) = @_; 530 $parser->on($tag => sub { $code->(@_) for $_[1] }); 531} 532sub walk { $parser->walk } 533 534# reads in a whole file 535sub slurp { 536 open my $fh, '<', shift; 537 local $/; 538 <$fh>; 539} 540 541sub spit { 542 my $file = shift; 543 open my $fh, '>', $file; 544 print $fh @_; 545 say "Writing: $file"; 546 close $fh; 547} 548 549sub perl_name($) { 550 my $x_name = shift; 551 # XXX hack: 552 # get potential extra ns like "xinerama" 553 (my $ns = $prefix) =~ s/^xcb_//; 554 555 return 'XCB' . ucfirst +($ns . decamelize($x_name)); 556} 557 558sub xcb_name($) { 559 my $x_name = shift; 560 return $prefix . decamelize($x_name); 561} 562 563sub xcb_type($) { 564 my $type = shift; 565 # XXX shouldn't those be in %xcbtype anyway? 566 return $xcbtype{$type} || xcb_name($type) . '_t'; 567} 568 569sub decamelize($) { 570 my ($camel) = @_; 571 572 my $special = [qw( 573 CHAR2B 574 INT64 575 FLOAT32 576 FLOAT64 577 BOOL32 578 STRING8 579 Family_DECnet 580 DECnet 581 )]; 582 583 return lc $camel if $camel ~~ $special; 584 585 # FIXME: eliminate this special case 586 return $camel if $camel =~ /^CUT_BUFFER/; 587 588 my $name = ''; 589 590 while (length($camel)) { 591 my ($char, $next) = ($camel =~ /^(.)(.*)$/); 592 593 $name .= lc($char); 594 595 if ( $camel =~ /^[[:lower:]][[:upper:]]/ 596 || $camel =~ /^\d[[:alpha:]]/ 597 || $camel =~ /^[[:alpha:]]\d/ 598 || $camel =~ /^[[:upper:]][[:upper:]][[:lower:]]/) 599 { 600 $name .= '_'; 601 } 602 603 $camel = $next; 604 } 605 606 return $name; 607} 608 609sub cname($) { 610 my $name = shift; 611 return "_$name" if $name ~~ [ qw/new delete class operator/ ]; 612 return $name; 613} 614 615sub indent (&$@) { 616 my ($code, $join, @input) = @_; 617 my $indent = ' ' x ($indent_level * 4); 618 619 return join $join, map { $indent . $code->() } @input; 620} 621 622() = $0 =~ (__PACKAGE__ . '.pm') ? generate() : 1; 623 624# Copyright (C) 2009 Michael Stapelberg <michael at stapelberg dot de> 625# Copyright (C) 2007 Hummingbird Ltd. All Rights Reserved. 626# 627# Permission is hereby granted, free of charge, to any person 628# obtaining a copy of this software and associated 629# documentation files (the "Software"), to deal in the 630# Software without restriction, including without limitation 631# the rights to use, copy, modify, merge, publish, distribute, 632# sublicense, and/or sell copies of the Software, and to 633# permit persons to whom the Software is furnished to do so, 634# subject to the following conditions: 635# 636# The above copyright notice and this permission notice shall 637# be included in all copies or substantial portions of the 638# Software. 639# 640# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY 641# KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE 642# WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR 643# PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS 644# BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 645# IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 646# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 647# OTHER DEALINGS IN THE SOFTWARE. 648# 649# Except as contained in this notice, the names of the authors 650# or their institutions shall not be used in advertising or 651# otherwise to promote the sale, use or other dealings in this 652# Software without prior written authorization from the 653# authors. 654