-#!/usr/bin/perl -w
-# 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 2 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, write to the Free Software
-# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
-# MA 02110-1301, USA.
-#
-# Copyright © 2007 Pierre Habouzit
-
-use strict;
-
-my %types;
-my %pkgs;
-
-#{{{ stream functions
-
-sub stream_open($) {
- my $name = shift;
- open FILE, $name;
- return (file => $name, line => 0, f => \*FILE);
-}
-
-sub stream_close($) {
- my $stream = shift;
- close $stream->{f};
-}
-
-sub stream_getline($) {
- my $stream = shift;
- my $file = $stream->{f};
- while (<$file>) {
- ${$stream}{line}++;
- return $_;
- }
- return;
-}
-
-#}}}
-
-#{{{ file:line functions
-
-sub fatal($$) {
- my ($stream, $msg) = @_;
- printf STDERR "%s:%d: %s\n", $stream->{file}, $stream->{line}, $msg;
- exit 1;
-}
-
-sub get_pos($$) {
- my ($h,$k) = @_;
- return $h->{$k}{file}.':'.$h->{$k}{line};
-}
-
-sub put_line($$) {
- my ($src,$inc) = @_;
- printf "#line %d \"%s\"\n", $src->{line} + $inc, $src->{file};
-}
-
-#}}}
-
-#{{{ parsers
-
-sub parse_type($$) {
- my ($src, $type) = @_;
- my %t = (
- name => $type,
- file => $src->{file},
- line => $src->{line},
- );
-
- if (defined $types{$type}) {
- my $pos = get_pos(\%types, $type);
- fatal($src, "already defined type: `$type' at $pos");
- }
-
- while (stream_getline($src)) {
- last if (/^\s*\}\s*;\s*/);
- if (/^\s*\.(kind|ctype|dtor|ctor|push|check)\s*=\s*(.*?)\s*;\s*$/) {
- $t{$1} = $2;
- if ($1 eq "kind") {
- if ($2 =~ /^'([bis])'$/) {
- $t{kind} = $1;
- } else {
- fatal($src, "error: .kind should be [ibs] got $2)");
- }
- }
- } elsif (!/^\s*$/) {
- fatal($src, "syntax error: unknown type directive");
- }
- }
-
- for ('kind', 'ctype') {
- fatal($src, "incomplete type $type: missing .$_") unless defined $t{$_};
- }
- if ($t{kind} eq 's') {
- for ('dtor', 'ctor') {
- fatal($src, "incomplete type $type: missing .$_") unless defined $t{$_};
- }
- }
- unless (defined $t{check}) {
- if ($t{kind} eq 'b') {
- $t{check} = '(luaL_checkint($L, $$) == 0)';
- }
-
- if ($t{kind} eq 'i') {
- $t{check} = 'luaL_checkint($L, $$)';
- }
-
- if ($t{kind} eq 's') {
- $t{check} = 'luaL_checkstring($L, $$)';
- }
- }
-
- $t{ctypefmt} .= ' %s' unless (($t{ctypefmt} = $t{ctype}) =~ s/:/ \%s :/);
- $t{ctype} =~ s/:.*//;
-
- return $types{$type} = \%t;
-}
-
-sub parse_package($$) {
- my ($src, $pkg) = @_;
- my %p = (
- name => $pkg,
- file => $src->{file},
- line => $src->{line},
- );
-
- if (defined $pkgs{$pkg}) {
- my $pos = get_pos(\%pkgs, $pkg);
- fatal($src, "already defined package: `$pkg' at $pos");
- }
-
- while (stream_getline($src)) {
- if (/^\s*\}\s*(\w+)\s*;\s*$/) {
- $p{cname} = $1;
- last;
- }
-
- if (/^\s*(.*?)\s*=\s*(.*?)\s*;\s*$/) {
- my ($lhs, $rhs) = ($1, $2);
- my %m = ( file => $src->{file}, line => $src->{line} );
-
- if ($lhs =~ /^((?:const\s+)?\w+?)\s*(\w+)$/) {
- $m{type} = $1;
- $m{name} = $2;
- $m{init} = $rhs;
- push @{$p{props}}, $2;
- } elsif ($lhs =~ /^((?:const\s+)?\w+?)\s*(\w*)\((.*)\)$/) {
- $m{type} = $1;
- $m{name} = $2;
- $m{proto} = $3;
- $m{cfun} = $rhs;
- push @{$p{meths}}, $2;
- } else {
- fatal($src, "syntax error");
- }
-
- if (defined $p{members}{$m{name}}) {
- my $pos = get_pos($p{members}{$m{name}}, 0);
- fatal($src, "already defined package member: `$m{name}' at $pos");
- }
-
- $p{members}{$m{name}} = \%m;
- next;
- }
-
- if (!/^\s*$/) {
- fatal($src, "syntax error");
- }
- }
-
- return $pkgs{$pkg} = \%p;
-}
-
-sub find_type($$) {
- my ($ref, $typ) = @_;
-
- if ($typ =~ /^const\s+(\w*)$/) {
- fatal($ref, "undefined type `$1'") unless defined $types{$1};
- return (const => 1, type => $types{$1});
- }
-
- fatal($ref, "undefined type `$typ'") unless defined $types{$typ};
- return (const => 0, type => $types{$typ});
-}
-
-#}}}
-
-#{{{ dump_fun
-
-sub dump_fun($$) {
- my ($pkg, $f) = @_;
- my %t = find_type($f, $f->{type});
- my $call = $f->{cfun};
- $call =~ s/\$/var/;
-
- print "static int luaM_${pkg}_$f->{name}(lua_State *L) {\n";
-
- if ($f->{proto} ne "void") {
- my $i = 1;
- for my $tmp (split /,/,$f->{proto}) {
- s/^\s+//;
- s/\s+$//;
-
- my %pt = find_type($f, $tmp);
- my $check = $pt{type}->{check};
- $check =~ s/\$L/L/;
- $check =~ s/\$\$/\%d/;
-
- put_line($pt{type}, 0);
- printf " $pt{type}->{ctype} var$i = $check\n", $i++;
- }
- }
-
- die "UNIMPLEMENTED" if defined $t{type}->{push};
-
- if ($t{type}->{kind} eq 'b') {
- put_line($f, 0);
- print " lua_pushboolean(L, $call);\n";
- }
-
- if ($t{type}->{kind} eq 'i') {
- put_line($f, 0);
- print " lua_pushint(L, $call);\n";
- }
-
- if ($t{type}->{kind} eq 's') {
- if ($t{const}) {
- put_line($f, 0);
- print " lua_pushstring(L, $call);\n";
- } else {
- print " {\n";
- put_line($f, 0);
- print " char *s = $call;\n";
- print " lua_pushstring(L, s);\n";
- print " p_delete(&s);\n";
- print " }\n";
- }
- }
-
- printf " return %d;\n", ($f->{type} ne "void");
- print "}\n";
-}
-
-#}}}
-
-#{{{ dump_struct
-
-sub dump_struct_full($) {
- my ($pkg) = @_;
-
- put_line($pkg, 0);
- print "struct luaM_$pkg->{name}_t $pkg->{cname} = {\n";
-
- foreach (@{$pkg->{props}}) {
- my $p = $pkg->{members}{$_};
- my %t = find_type($p, $p->{type});
-
- if ($t{const}) {
- put_line($p, 0);
- print " $p->{init},\n";
- } else {
- print " 0,\n" if ($t{type}->{kind} eq 'b');
- print " 0,\n" if ($t{type}->{kind} eq 'i');
- print " NULL,\n" if ($t{type}->{kind} eq 's');
- }
- }
-
- print <<EOF;
-};
-
-static void $pkg->{cname}_init(void)
-{
-EOF
-
- foreach (@{$pkg->{props}}) {
- my $p = $pkg->{members}{$_};
- my %t = find_type($p, $p->{type});
- my $var = $pkg->{cname}.".".$p->{name};
-
- next if $t{const};
-
- put_line($p, 0);
- if ($t{type}->{dtor}) {
- my $dtor = $t{type}->{dtor};
- $dtor =~ s/\$L/L/;
- $dtor =~ s/\$\$/\&$var/;
- print " $dtor;\n";
- }
- print " $var = $p->{init};\n"
- }
- print "};\n";
-};
-
-sub dump_struct_short($) {
- my ($pkg) = @_;
-
- print "struct luaM_$pkg->{name}_t {\n";
- foreach (@{$pkg->{props}}) {
- my $p = $pkg->{members}{$_};
- my %t = find_type($p, $p->{type});
- if ($t{const}) {
- printf " const $t{type}->{ctypefmt};\n", $p->{name};
- } else {
- printf " $t{type}->{ctypefmt};\n", $p->{name};
- }
- }
- put_line($pkg, 0);
- print <<EOF;
-};
-
-extern struct luaM_$pkg->{name}_t $pkg->{cname};
-EOF
-}
-
-sub dump_struct_static($) {
- my ($pkg) = @_;
-
- print "static struct {\n";
- foreach (@{$pkg->{props}}) {
- my $p = $pkg->{members}{$_};
- my %t = find_type($p, $p->{type});
- if ($t{const}) {
- printf " const $t{type}->{ctypefmt};\n", $p->{name};
- } else {
- printf " $t{type}->{ctypefmt};\n", $p->{name};
- }
- }
- put_line($pkg, 0);
- print "} $pkg->{cname} = {\n";
-
- foreach (@{$pkg->{props}}) {
- my $p = $pkg->{members}{$_};
- my %t = find_type($p, $p->{type});
-
- if ($t{const}) {
- put_line($p, 0);
- print " $p->{init},\n";
- } else {
- print " 0,\n" if ($t{type}->{kind} eq 'b');
- print " 0,\n" if ($t{type}->{kind} eq 'i');
- print " NULL,\n" if ($t{type}->{kind} eq 's');
- }
- }
-
- print <<EOF;
-};
-
-static void $pkg->{cname}_init(void)
-{
-EOF
-
- foreach (@{$pkg->{props}}) {
- my $p = $pkg->{members}{$_};
- my %t = find_type($p, $p->{type});
- my $var = $pkg->{cname}.".".$p->{name};
-
- next if $t{const};
-
- put_line($p, 0);
- if ($t{type}->{dtor}) {
- my $dtor = $t{type}->{dtor};
- $dtor =~ s/\$L/L/;
- $dtor =~ s/\$\$/\&$var/;
- print " $dtor;\n";
- }
- print " $var = $p->{init};\n"
- }
- print "};\n";
-};
-
-#}}}
-
-#{{{ dump package
-
-sub dump_package_full($$) {
- my ($pkg, $static) = @_;
-
- if ($static) {
- dump_struct_static($pkg);
- } else {
- dump_struct_full($pkg);
- }
- map { print "\n"; dump_fun($pkg->{name}, $pkg->{members}{$_}); } @{$pkg->{meths}};
- print <<EOF;
-
-static const luaL_reg luaM_$pkg->{name}_methods[] = {
-EOF
- map { print " { \"$_\", luaM_$pkg->{name}_$_ },\n"; } @{$pkg->{meths}};
- print <<EOF;
- { NULL, NULL }
-};
-
-static int luaM_$pkg->{name}_index(lua_State *L)
-{
- const char *idx = luaL_checkstring(L, 2);
-
- switch (mlua_which_token(idx, -1)) {
-EOF
-
- foreach (@{$pkg->{props}}) {
- my $p = $pkg->{members}{$_};
- my %t = find_type($p, $p->{type});
- my $call = $t{type}->{push} || '$$';
-
- $call =~ s/\$L/L/;
- $call =~ s/\$\$/$pkg->{cname}.$p->{name}/;
-
- my $tok = $p->{name};
- $tok =~ tr/a-z/A-Z/;
-
- if ($t{type}->{kind} eq 'b') {
- $call = "lua_pushboolean(L, $call)";
- }
-
- if ($t{type}->{kind} eq 'i') {
- $call = "lua_pushinteger(L, $call)";
- }
-
- if ($t{type}->{kind} eq 's') {
- $call = "lua_pushstring(L, $call)";
- }
-
- put_line($p, 0);
- print " case LTK_$tok:\n";
- printf " $call;\n";
- print " return 1;\n";
- }
-
-print <<EOF;
- default:
- lua_rawget(L, lua_upvalueindex(2)); /* try methods */
- return 1;
- }
-}
-
-static int luaM_$pkg->{name}_newindex(lua_State *L)
-{
- const char *idx = luaL_checkstring(L, 2);
-
- switch (mlua_which_token(idx, -1)) {
-EOF
-
- foreach (@{$pkg->{props}}) {
- my $p = $pkg->{members}{$_};
- my %t = find_type($p, $p->{type});
-
- next if ($t{const});
-
- my $tok = $p->{name};
- my $var = $pkg->{cname}.".".$p->{name};
- my $check = $t{type}->{check};
- $tok =~ tr/a-z/A-Z/;
- $check =~ s/\$L/L/;
- $check =~ s/\$\$/3/;
-
- put_line($p, 0);
- print " case LTK_$tok: \n";
- if ($t{type}->{dtor}) {
- my $dtor = $t{type}->{dtor};
- $dtor =~ s/\$L/L/;
- $dtor =~ s/\$\$/\&$var/;
- print " $dtor;\n";
- }
- if ($t{type}->{ctor}) {
- my $ctor = $t{type}->{ctor};
- $ctor =~ s/\$L/L/;
- $ctor =~ s/\$\$/$check/;
- $check = $ctor;
- }
- print " $var = $check;\n";
- print " return 1;\n";
- }
-
-print <<EOF;
- default:
- return 1;
- }
-}
-
-int luaopen_$pkg->{name}(lua_State *L)
-{
- int mt, methods;
-
- $pkg->{cname}_init();
-
- /* create methods table, add it the the table of globals */
- luaL_openlib(L, "$pkg->{name}", luaM_$pkg->{name}_methods, 0);
- methods = lua_gettop(L);
-
- /* create metatable for $pkg->{name}, add it to the registry */
- luaL_newmetatable(L, "$pkg->{name}");
- mt = lua_gettop(L);
-
- lua_pushliteral(L, "__index");
- lua_pushvalue(L, mt); /* upvalue 1 */
- lua_pushvalue(L, methods); /* upvalue 2 */
- lua_pushcclosure(L, &luaM_$pkg->{name}_index, 2);
- lua_rawset(L, mt); /* set mt.__index */
-
- lua_pushliteral(L, "__newindex");
- lua_newtable(L); /* for new members */
- lua_pushcclosure(L, &luaM_$pkg->{name}_newindex, 1);
- lua_rawset(L, mt); /* set mt.__newindex */
-
- lua_pushliteral(L, "__metatable");
- lua_pushvalue(L, methods); /* dup methods table */
- lua_rawset(L, mt); /* hide metatable */
-
- lua_setmetatable(L, methods);
-
- lua_pop(L, 1); /* drop mt */
- return 1; /* return methods */
-}
-
-EOF
-}
-
-sub dump_package_short($) {
- my $pkg = shift;
- my $upp = $pkg->{name};
- $upp =~ tr/a-z/A-Z/;
-
- print <<EOF;
-#ifndef MUTT_LUA_${upp}_H
-#define MUTT_LUA_${upp}_H
-
-EOF
- dump_struct_short($pkg);
- print <<EOF
-
-int luaopen_$pkg->{name}(lua_State *L);
-
-#endif /* MUTT_LUA_${upp}_H */
-EOF
-}
-
-#}}}
-
-sub do_c($) {
- my %src = stream_open(shift);
- my $resync = 1;
-
- while (stream_getline(\%src)) {
- if (/^\s*\@type\s+([a-zA-Z]\w*)\s*=\s*{\s*$/) {
- parse_type(\%src, $1);
- $resync = 1;
- } elsif (/^\s*static\s+\@package\s+([a-zA-Z]\w*)\s+{\s*$/) {
- dump_package_full(parse_package(\%src, $1), 1);
- $resync = 1;
- } elsif (/^\s*\@package\s+([a-zA-Z]\w*)\s+{\s*$/) {
- dump_package_full(parse_package(\%src, $1), 0);
- $resync = 1;
- } elsif (/^\s*(\@\w*)/) {
- fatal(\%src, "syntax error: unknown directive `$1'");
- } else {
- next if ($resync && /^\s+$/);
- if ($resync) {
- put_line(\%src, 0);
- $resync = 0;
- }
- print;
- }
- }
-
- stream_close(\%src);
-}
-
-sub do_h($) {
- my %src = stream_open(shift);
- my $resync = 1;
-
- while (stream_getline(\%src)) {
- if (/^\s*\@type\s+([a-zA-Z]\w*)\s*=\s*{\s*$/) {
- parse_type(\%src, $1);
- } elsif (/^\s*\@package\s+([a-zA-Z]\w*)\s+{\s*$/) {
- dump_package_short(parse_package(\%src, $1));
- } elsif (/^\s*(\@\w*)/) {
- fatal(\%src, "syntax error: unknown directive `$1'");
- }
- }
-
- stream_close(\%src);
-}
-
-if ($#ARGV < 1 || ($ARGV[0] ne "-h" && $ARGV[0] ne "-c")) {
- print <<EOF;
-usage: mluapkg (-h | -c) file.pkg
-EOF
- exit 1;
-}
-
-print <<EOF;
-/***** THIS FILE IS AUTOGENERATED DO NOT MODIFY DIRECTLY ! *****/
-EOF
-
-map { do_h($ARGV[$_]); } (1 .. $#ARGV) if ($ARGV[0] eq '-h');
-map { do_c($ARGV[$_]); } (1 .. $#ARGV) if ($ARGV[0] eq '-c');
projects / apps / madmutt.git / commitdiff