_GenerateMyXS.pm - metacpan.org

#!/usr/bin/env perl
# vim:ts=4:sw=4:expandtab

# Known bugs:
# - Does not support _checked or _unchecked variants of function calls
# - Allows Lua to underflow and (maybe) crash C, when it should lua_error instead (so pcall can catch it)
# - ChangeProperty is limited to the 8-bit datatype

# Known warts:
# - Should get string lengths (and other lengths) from Lua, instead of requiring the length to be passed from the script

package _GenerateMyXS;

use strict; use warnings; use v5.10;
use autodie;
use Data::Dump;
use List::Util qw(first);
use Cwd qw(abs_path);

use XML::Simple qw(:strict);

use XML::Descent;
my $parser;

# forward declarations of utility functions:
sub on; sub walk;    # parser
sub slurp; sub spit; # file reading/writing
# name mangeling:
sub decamelize($); sub xcb_name($); sub xcb_type($); sub perl_name($); sub cname($);

sub indent (&$@); # templating
our $indent_level = 1;

my $prefix = 'xcb_';
my %const;

# The tmpl_* function push their generated code onto those arrays,
# &generate in turn writes and empties them.
my (@struct, @request);

# XXX currently unused:
# In contrary to %xcbtype, which only holds basic data types like 'int', 'char'
# and so on, the %exacttype hash holds the real type name, like INT16 or CARD32
# for any type which has been specified in the XML definition. For example,
# type KEYCODE is an alias for CARD32. This is necessary later on to correctly
# typecast our intArray type.
my %exacttype = ();

my %xcbtype = (
    BOOL   => 'int',
    BYTE   => 'uint8_t',
    CARD8  => 'uint8_t',
    CARD16 => 'uint16_t',
    CARD32 => 'uint32_t',
    INT8   => 'uint8_t',
    INT16  => 'uint16_t',
    INT32  => 'uint32_t',

    char   => 'char',
    void   => 'void',     # Hack, to partly support ChangeProperty, until we can reverse 'op'.
    float  => 'double',
    double => 'double',
);

sub tmpl_struct {
    my ($name, $params, $types) = @_;

    my $constructor = 'new';

    my $param = join ',', @$params;
    my $param_decl = indent { "$types->{$_} $_" } "\n", @$params;
    my $set_struct = indent { 'buf->' . cname($_) . " = $_;" } "\n", @$params;

    push @struct, << "__"
MODULE = X11::XCB PACKAGE = $name
$name *
$constructor(self,$param)
    char *self
$param_decl
  PREINIT:
    $name *buf;
  CODE:
    New(0, buf, 1, $name);
$set_struct
    RETVAL = buf;
  OUTPUT:
    RETVAL

__
}

sub tmpl_struct_getter {
    my ($pkg, $name, $type) = @_;
    my $cname = cname($name);

    push @struct, << "__"
MODULE = X11::XCB PACKAGE = ${pkg}Ptr

$type
$name(self)
    $pkg * self
  CODE:
    RETVAL = self->$cname;
  OUTPUT:
    RETVAL

__
}

sub tmpl_request {
    my ($name, $cookie, $params, $types, $xcb_cast, $cleanups) = @_;

    my $param = join ',', ('conn', @$params);
    my @param = grep { $_ ne '...' } @$params;

    my $param_decl = indent { "$types->{$_} $_" } "\n", @param;

    # XXX should be "$prefix$name", but $name has already a prefix like xinerama_
    my $xcb_name = "xcb_$name";
    my $xcb_param = do {
        local $indent_level = 0;
        $xcb_cast->{conn} = '';
        indent { $xcb_cast->{$_} . $_ } ', ', ('conn', @param);
    };
    my $cleanup = indent { "free($_);" } "\n", @$cleanups;

    push @request, << "__"
HV *
$name($param)
    XCBConnection *conn
$param_decl
  PREINIT:
    HV * hash;
    $cookie cookie;
  CODE:
    cookie = $xcb_name($xcb_param);

    hash = newHV();
    hv_store(hash, "sequence", strlen("sequence"), newSViv(cookie.sequence), 0);
    RETVAL = hash;
$cleanup
  OUTPUT:
    RETVAL

__
}

sub on_field {
    my ($fields, $types) = @_;

    on field => sub {
        my $name = $_->{name};
        push @$fields, $name;

        my $type = xcb_type($_->{type});
        # XXX why not XCB\u$1?
        $type =~ s/^xcb_/XCB/;
        $types->{$name} = $type;
    }
}

sub do_structs {
    my $x_name = $_->{name};
    my $xcb_type = xcb_type $x_name;
    my $perlname = perl_name $x_name;

    print OUTTD " typedef $xcb_type $perlname;\n";
    print OUTTM "$perlname * T_PTROBJ\n";

    my (@fields, %type);
    on_field(\@fields, \%type);

    my $dogetter = 1;

    my %nostatic = (    # These structs are used from the base protocol
        xcb_setup_t => 1,
    );

    # TODO: unimplemented
    on list => sub {
        $dogetter = 0;    # If it has a list, the get half shouldn't (can't?) be needed.
    };

    # TODO: unimplemented
    # on union => sub { on [ qw/field list/ ] => sub {} };

    walk;

    tmpl_struct($perlname, \@fields, \%type);

    if ($dogetter) {
        tmpl_struct_getter($perlname, $_, $type{$_}) for @fields;
    }

}

sub do_typedefs {
    my $e = shift;

    if ($e eq 'typedef') {
        $xcbtype{ $_->{newname} }      = $xcbtype{ $_->{oldname} };
        $exacttype{ $_->{newname} }    = $_->{oldname};
    }
    elsif ($e =~ /^(?:xidtype|xidunion)/) {
        $xcbtype{ $_->{name} }      = $xcbtype{CARD32};
    }
}

# items is already in use by XS, see perlapi
# <Variables created by "xsubpp" and "xsubpp" internal functions> for more
# XXX this is currently only used in do_request/on list
sub param_sanitize {
    $_[0] eq 'items' ? 'items_' : $_[0]
}

sub do_requests {
    my $x_name = $_->{name};
    my $xcb_name  = xcb_name $x_name;

    # XXX hack, to get eg. a xinerama_ prefix
    (my $ns = $prefix) =~ s/^xcb_//;

    my $name = $ns . decamelize $x_name;

    my (@param, %type, %xcb_cast, @cleanup);

    on_field(\@param, \%type);

    # array length
    # TODO : rid _len from parameters, use XS to get the length of strings, etc
    on list => sub {
        my $param = param_sanitize($_->{name});
        my $x_type = $_->{type};

        my $push_len = 1;
        on [ qw/fieldref op value/ ] => sub { $push_len = 0 };
        walk;

        push @param, $param . '_len' if $push_len;
        push @param, $param;

        my $type = $xcbtype{$x_type} || perl_name $x_type;

        if ($type =~ /^uint(?:8|16|32)_t$/) {
            $xcb_cast{$param} = " (const $type*)";
            $type = 'intArray'
        }

        # We use char* instead of void* to be able to use pack() in the perl part
        $type = 'char' if $type eq 'void';

        $type{$param} = "$type *";
        $type{$param . '_len'} = 'int' if $push_len;

        push @cleanup, $param unless $type =~ /^(?:char|void)$/;
    };

    # bitmask -> list of value.
    # TODO: ideally this would be a hashref eg. C< { bitname => "value", … } >
    on valueparam => sub {
        my ($mask, $list, $type) = @{$_}{qw/value-mask-name value-list-name value-mask-type/};
        push @param, $mask
        # eg. ConfigureWindow already specifies the mask via <field />
            unless ($param[-1] || '') eq $mask;

        push @param, $list;
        push @param, '...';

        $type{$mask} = xcb_type $type;
        $type{$list} = 'intArray *';

        push @cleanup, $list;
    };

    my $cookie = 'xcb_void_cookie_t';
    on reply => sub { $cookie = $xcb_name . '_cookie_t'; 'do_reply(@_)' };
    walk;

    $xcb_cast{$_} ||= '' for @param;

    tmpl_request($name, $cookie, \@param, \%type, \%xcb_cast, \@cleanup);

}

sub do_events($) {
    my $xcb = shift;
    my %events;

    # TODO: events
}

sub do_replies($\%\%) {
    my ($xcb, $func, $collect) = @_;

    for my $req (@{ $xcb->{request} }) {
        my $rep = $req->{reply};
        next unless defined($rep);
        # request should return a cookie object, blessed into the right pkg
        # $perlname should be set fixed to 'reply'

        my $name     = xcb_name($req->{name}) . "_reply";
        my $reply    = xcb_name($req->{name}) . "_reply_t";
        my $perlname = $name;
        $perlname =~ s/^xcb_//g;
        my $cookie = xcb_name($req->{name}) . "_cookie_t";

        print OUT "HV *\n$perlname(conn,sequence)\n";
        print OUT "    XCBConnection *conn\n";
        print OUT "    int sequence\n";
        print OUT "  PREINIT:\n";
        print OUT "    HV * hash;\n";
        print OUT "    HV * inner_hash;\n";
        print OUT "    AV * alist;\n";
        print OUT "    int c;\n";
        print OUT "    int _len;\n";
        print OUT "    $cookie cookie;\n";
        print OUT "    $reply *reply;\n";
        print OUT "  CODE:\n";
        print OUT "    cookie.sequence = sequence;\n";
        print OUT "    reply = $name(conn, cookie, NULL);\n";
        # XXX use connection_has_error
        print OUT qq/    if (!reply) croak("Could not get reply for: $name"); /;
        print OUT "    hash = newHV();\n";

        # We ignore pad0 and response_type. Every reply has sequence and length
        print OUT "    hv_store(hash, \"sequence\", strlen(\"sequence\"), newSViv(reply->sequence), 0);\n";
        print OUT "    hv_store(hash, \"length\", strlen(\"length\"), newSViv(reply->length), 0);\n";
        for my $var (@{ $rep->[0]->{field} }) {
            my $type = xcb_type($var->{type});
            my $name = cname($var->{name});
            if ($type =~ /^(?:uint(?:8|16|32)_t|int)$/) {
                print OUT "    hv_store(hash, \"$name\", strlen(\"$name\"), newSViv(reply->$name), 0);\n";
            } else {
                print OUT "    /* TODO: type $type, name $var->{name} */\n";
            }
        }

        for my $list (@{ $rep->[0]->{list} }) {
            my $listname      = $list->{name};
            my $type          = xcb_name($list->{type}) . '_t';
            my $iterator      = xcb_name($list->{type}) . '_iterator_t';
            my $iterator_next = xcb_name($list->{type}) . '_next';
            my $pre           = xcb_name($req->{name});

            if ($list->{type} eq 'void') {

                # A byte-array. Provide it as SV.
                print OUT "    _len = reply->value_len * (reply->format / 8);\n";
                print OUT "    if (_len > 0)\n";
                print OUT "        hv_store(hash, \"value\", strlen(\"value\"), newSVpvn((const char*)(reply + 1), _len), 0);\n";
                next;
            }

            # Get the type description of the list’s members
            my $struct = first { $_->{name} eq $list->{type} } @{ $xcb->{struct} };

            next unless defined($struct->{field}) && scalar(@{ $struct->{field} }) > 0;

            print OUT "    {\n";
            print OUT "    /* Handling list part of the reply */\n";
            print OUT "    alist = newAV();\n";
            print OUT "    $iterator iterator = $pre" . '_' . $listname . "_iterator(reply);\n";
            print OUT "    for (; iterator.rem > 0; $iterator_next(&iterator)) {\n";
            print OUT "      $type *data = iterator.data;\n";
            print OUT "      inner_hash = newHV();\n";

            for my $field (@{ $struct->{field} }) {
                my $type = xcb_type($field->{type});
                my $name = cname($field->{name});

                if ($type =~ /^(?:uint(?:8|16|32)_t|int)$/) {
                    print OUT "      hv_store(inner_hash, \"$name\", strlen(\"$name\"), newSViv(data->$name), 0);\n";
                } else {
                    print OUT "      /* TODO: type $type, name $name */\n";
                }
            }
            print OUT "      av_push(alist, newRV((SV*)inner_hash));\n";

            print OUT "    }\n";
            print OUT "    hv_store(hash, \"" . $list->{name} . "\", strlen(\"" . $list->{name} . "\"), newRV((SV*)alist), 0);\n";

            print OUT "    }\n";
        }

        #print Dumper($rep);
        #if (defined($rep->{list})) {

        print OUT "    RETVAL = hash;\n";
        print OUT "  OUTPUT:\n    RETVAL\n\n";
    }
}

sub do_enums {
    my ($tag, $attr) = @_;

    my $name = uc decamelize $attr->{name};

    if ($tag eq 'enum') {
        on item => sub {
            my $tname = $name . "_" . uc decamelize $_->{name};
            $const{$tname} = "newSViv(XCB_$tname)";
        };
        walk;

    }
    elsif ($tag eq 'event') { # =~ /^(?:event|eventcopy|error|errorcopy)$/) {
        $const{$name} = "newSViv(XCB_$name)";
    }

}

sub generate {
    my $path = abs_path() . '/bundled-libs/xcb-proto-1.7.1/src';
    my @xcb_xmls = qw/xproto.xml xinerama.xml/;

    -d $path or die "$path: $!\n";

    # TODO: Handle all .xmls
    #opendir(DIR, '.');
    #@files = grep { /\.xml$/ } readdir(DIR);
    #closedir DIR;

    my @files = map {
        my $xml = "$path/$_";
        -r $xml or die "$xml: $!\n";
        $xml
    } @xcb_xmls;

    open(OUT,   ">XCB_xs.inc");
    open(OUTTM, ">typemap");
    open(OUTTD, ">typedefs.h");

    print OUTTM << '__';
XCBConnection *             T_PTROBJ_MG
intArray *                  T_ARRAY
X11_XCB_ICCCM_WMHints *     T_PTROBJ
X11_XCB_ICCCM_SizeHints *   T_PTROBJ
uint8_t                     T_U_CHAR
uint16_t                    T_U_SHORT
uint32_t                    T_UV
__



    # Our own additions: EWMH constants
    $const{_NET_WM_STATE_ADD}    = 'newSViv(1)';
    $const{_NET_WM_STATE_REMOVE} = 'newSViv(0)';
    $const{_NET_WM_STATE_TOGGLE} = 'newSViv(2)';

    # ICCCM constants from xcb-util
    for my $const (qw(XCB_ICCCM_WM_STATE_WITHDRAWN XCB_ICCCM_WM_STATE_NORMAL XCB_ICCCM_WM_STATE_ICONIC)) {
        my ($name) = ($const =~ /XCB_(.*)/);
        $const{$name} = "newSViv($const)";
    }

    for my $path (@files) {
        say "Processing: $path";
        my $xcb = XMLin("$path", KeyAttr => undef, ForceArray => 1);

        $parser = XML::Descent->new({ Input => $path });

        on xcb => sub {
            my ($e, $attr) = @_;
            my $name = $attr->{header};

            $prefix = $name eq 'xproto' ? 'xcb_' : "xcb_${name}_";

            on [ qw/enum event eventcopy error errorcopy/ ] => \&do_enums;
            on [ qw/typedef xidtype xidunion/ ] => \&do_typedefs;
            on struct => \&do_structs;
            on request => \&do_requests;
            walk;
        };
        walk;

        print OUT @struct;
        undef @struct;

        do_events($xcb);

        print OUT "MODULE = X11::XCB PACKAGE = X11::XCB\n";
        print OUT @request;
        undef @request;

        &do_replies($xcb);


    }

    close OUT;
    close OUTTM;
    close OUTTD;

    my @const = sort keys %const;

    spit 'XCB.inc', << "__",
static void boot_constants(HV *stash, AV *tags_all) {
    av_extend(tags_all, ${\ scalar @const });
__
        (map { << "__" } @const),
    newCONSTSUB(stash, "$_", $const{$_});
    av_push(tags_all, newSVpvn("$_", ${\ length $_ }));
__
        "}\n";
}

# utility functions

sub on {
    my ($tag, $code) = @_;
    $parser->on($tag => sub { $code->(@_) for $_[1] });
}
sub walk { $parser->walk }

# reads in a whole file
sub slurp {
    open my $fh, '<', shift;
    local $/;
    <$fh>;
}

sub spit {
    my $file = shift;
    open my $fh, '>', $file;
    print $fh @_;
    say "Writing: $file";
    close $fh;
}

sub perl_name($) {
    my $x_name = shift;
    # XXX hack:
    # get potential extra ns like "xinerama"
    (my $ns = $prefix) =~ s/^xcb_//;

    return 'XCB' . ucfirst +($ns . decamelize($x_name));
}

sub xcb_name($) {
    my $x_name = shift;
    return $prefix . decamelize($x_name);
}

sub xcb_type($) {
    my $type = shift;
    # XXX shouldn't those be in %xcbtype anyway?
    return $xcbtype{$type} || xcb_name($type) . '_t';
}

sub decamelize($) {
    my ($camel) = @_;

    my $special = [qw(
        CHAR2B
        INT64
        FLOAT32
        FLOAT64
        BOOL32
        STRING8
        Family_DECnet
        DECnet
   )];

    return lc $camel if $camel ~~ $special;

    # FIXME: eliminate this special case
    return $camel if $camel =~ /^CUT_BUFFER/;

    my $name = '';

    while (length($camel)) {
        my ($char, $next) = ($camel =~ /^(.)(.*)$/);

        $name .= lc($char);

        if (   $camel =~ /^[[:lower:]][[:upper:]]/
            || $camel =~ /^\d[[:alpha:]]/
            || $camel =~ /^[[:alpha:]]\d/
            || $camel =~ /^[[:upper:]][[:upper:]][[:lower:]]/)
        {
            $name .= '_';
        }

        $camel = $next;
    }

    return $name;
}

sub cname($) {
    my $name = shift;
    return "_$name" if $name ~~ [ qw/new delete class operator/ ];
    return $name;
}

sub indent (&$@) {
    my ($code, $join, @input) = @_;
    my $indent = ' ' x ($indent_level * 4);

    return join $join, map { $indent . $code->() } @input;
}

() = $0 =~ (__PACKAGE__ . '.pm') ? generate() : 1;

# Copyright (C) 2009 Michael Stapelberg <michael at stapelberg dot de>
# Copyright (C) 2007 Hummingbird Ltd. All Rights Reserved.
#
# Permission is hereby granted, free of charge, to any person
# obtaining a copy of this software and associated
# documentation files (the "Software"), to deal in the
# Software without restriction, including without limitation
# the rights to use, copy, modify, merge, publish, distribute,
# sublicense, and/or sell copies of the Software, and to
# permit persons to whom the Software is furnished to do so,
# subject to the following conditions:
#
# The above copyright notice and this permission notice shall
# be included in all copies or substantial portions of the
# Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY
# KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE
# WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
# PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS
# BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
# IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
# OTHER DEALINGS IN THE SOFTWARE.
#
# Except as contained in this notice, the names of the authors
# or their institutions shall not be used in advertising or
# otherwise to promote the sale, use or other dealings in this
# Software without prior written authorization from the
# authors.
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)