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