view release on metacpan or  search on metacpan

tools/regen.pl  view on Meta::CPAN

use strict;
use warnings;
use autodie;
use List::MoreUtils qw/uniq/;

sub read_xs_decl {
    my ($path) = @_;

    open my $xs, "<", $path;

    my (@decl, @temp);
    my ($module, $package);

    while (<$xs>) {
        chomp;
        # skip lines that start with whitespace, comments and XS directives.
        next if /^(\s|#|$|[A-Z]+:)/;
        if (/^MODULE\s*=\s*([^\s]+)\s+PACKAGE\s*=\s*([^\s]+)/) {
            $module = $1;
            $package = $2;
            next;
        }

        if (/^=/) {
            while (<$xs> !~ /^=cut/) {};
            next;
        }
        push @temp, $_;
        if (@temp == 2) {
            my ($name, $args) = $temp[1] =~ /^([^(]+)(.*)/;
            push @decl, {
                module => $module,
                package => $package,
                type => $temp[0],
                name => $name,
                args => $args,
            };
            @temp = ();
        }
    }

    return \@decl;
}

my $xs_decls = read_xs_decl("GCCJIT.xs");

print "# DO NOT EDIT - this file is autogenerated by tools/regen.pl\n";
print "package GCCJIT::Wrapper;\n";
print "use strict;\n";
print "use warnings;\n";
print "use Scalar::Util qw/weaken/;\n";
print "use $_;\n" foreach (uniq sort map $_->{package}, @$xs_decls);

print "\nmy %stash;\n";

my %destructor_code;

sub is_memory_owner {
    shift() =~ /^gcc_jit_(context|result)Ptr$/;
}

sub is_managed_type {
    my $type = shift;
    $type =~ /^gcc_jit_/ && !is_memory_owner($type)
}

foreach my $decl (sort { $a->{name} cmp $b->{name} } @$xs_decls) {
    my ($class, $method) = $decl->{name} =~ /gcc_jit_([a-z]+)_(.*)/;

    my $objpkg = "gcc_jit_${class}Ptr";
    my $retpkg = $decl->{type} =~ s/\s*\*/Ptr/r;

    if ($method eq "get_context") {
        print "sub ${objpkg}::${method} {\n";
        print "    \$stash{\"$objpkg\"}{\$_[0]}\n";
        print "}\n\n";
        next;
    }
    if ($method eq "release") {
        $destructor_code{$objpkg}{release} = "$decl->{package}::$decl->{name}(\$_[0])";
        next;
    }

    my $need_check = is_managed_type($objpkg);
    my $need_stash = is_managed_type($retpkg) || $objpkg eq $retpkg;
    my $need_weaken = is_managed_type($retpkg);

    if ($need_stash) {
        $destructor_code{$retpkg}{unstash} = "delete \$stash{\"$retpkg\"}{\$_[0]}";
    }

    unless ($need_check || $need_stash) {
        print "*${objpkg}::${method} = \\&$decl->{package}::$decl->{name};\n\n";
    } else {
        print "sub ${objpkg}::${method} {\n";

        if ($need_check) {
            print "    die \"this $class is no longer usable because parent context was destroyed\"\n";
            print "        unless defined \$stash{\"$objpkg\"}{\$_[0]};\n";
        }

        print "    ";
        print "my \$obj = " if ($need_stash);
        print "$decl->{package}::$decl->{name}(\@_);\n";

        if ($need_stash) {
            print "    if (defined \$obj) {\n";
            if ($objpkg eq "gcc_jit_contextPtr") {
                print "        \$stash{\"$retpkg\"}{\$obj} = \$_[0];\n";
            }
            else {
                print "        \$stash{\"$retpkg\"}{\$obj} = \$stash{\"$objpkg\"}{\$_[0]};\n";
            }
            if ($need_weaken) {
                print "        weaken \$stash{\"$retpkg\"}{\$obj};\n";
            }

            print "    }\n";
            print "    \$obj;\n";
        }
        print "}\n\n";
    }
}

foreach my $pkg (sort keys %destructor_code) {
    my $code = $destructor_code{$pkg};
    print "sub ${pkg}::DESTROY {\n";
    print "    $_;\n" foreach (values %$code);
    print "}\n\n";
}

print "1;\n";
print <DATA>;
__DATA__
__END__
=head1 NAME

GCCJIT::Wrapper - object oriented wrapper for GCCJIT.

=head1 DESCRIPTION

Do not use this package directly. Instead, use L<GCCJIT::Context>.

=head1 AUTHOR

Vickenty Fesunov E<lt>cpan-gccjit@setattr.netE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2015 by Vickenty Fesunov.

This program is free software: you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

This program is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU General Public License for more details.

You should have received a copy of the GNU General Public License along with
this program.  If not, see <http://www.gnu.org/licenses/>.

=cut