+#!/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*\.(push|kind|ctype|check)\s*=\s*(.*?)\s*;\s*$/) {
+ $t{$1} = $2;
+ if ($1 eq "kind") {
+ if ($2 =~ /^'([si])'$/) {
+ $t{kind} = $1;
+ } else {
+ fatal($src, "error: .kind should be 'i' or 's' got $2)");
+ }
+ }
+ } elsif (!/^\s*$/) {
+ fatal($src, "syntax error: unknown type directive");
+ }
+ }
+
+ for my $i ('kind', 'ctype') {
+ fatal($src, "incomplete type $type: missing .$i") unless defined $t{$i};
+ }
+ unless (defined $t{check}) {
+ if ($t{kind} eq 's') {
+ $t{check} = 'luaL_checkstring($L, $$)';
+ }
+
+ if ($t{kind} eq 'i') {
+ $t{check} = 'luaL_checkint($l, $$)';
+ }
+ }
+
+ 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++;
+ }
+ }
+
+ if (defined $t{type}->{push}) {
+ $call =~ s/\$\$/$t{type}->{push}/;
+ }
+
+ 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";
+ }
+ }
+
+ if ($t{type}->{kind} eq 'i') {
+ put_line($f, 0);
+ print " lua_pushint(L, $call);\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 '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);
+ print " m_strreplace(&$var, $p->{init});\n" if ($t{type}->{kind} eq 's');
+ print " $var = $p->{init};\n" if ($t{type}->{kind} eq 'i');
+ }
+ 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});
+ print " $t{type}->{ctype} $p->{name};\n";
+ }
+ put_line($pkg, 0);
+ print <<EOF;
+};
+
+extern struct luaM_$pkg->{name}_t $pkg->{cname};
+EOF
+}
+
+#}}}
+
+#{{{ dump package
+
+sub dump_package_full($) {
+ my $pkg = shift;
+
+ 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 = $pkg->{cname}.".".$p->{name};
+
+ my $tok = $p->{name};
+ $tok =~ tr/a-z/A-Z/;
+
+ if ($t{type}->{kind} eq 's') {
+ $call = "lua_pushstring(L, $call)";
+ }
+
+ if ($t{type}->{kind} eq 'i') {
+ $call = "lua_pushinteger(L, $call)";
+ }
+
+ if (defined $t{type}->{push}) {
+ $call =~ s/\$\$/$t{type}->{push}/;
+ }
+
+ 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";
+ print " m_strreplace(&$var, $check)" if ($t{type}->{kind} eq 's');
+ print " $var = $check" if ($t{type}->{kind} eq 'i');
+
+ print ";\n 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*\@package\s+([a-zA-Z]\w*)\s+{\s*$/) {
+ dump_package_full(parse_package(\%src, $1));
+ $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;
+ }
+ }
+ print "/* vi"."m:set ft=c: */\n";
+
+ 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