2 # This program is free software; you can redistribute it and/or modify
3 # it under the terms of the GNU General Public License as published by
4 # the Free Software Foundation; either version 2 of the License, or (at
5 # your option) any later version.
7 # This program is distributed in the hope that it will be useful, but
8 # WITHOUT ANY WARRANTY; without even the implied warranty of
9 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
10 # General Public License for more details.
12 # You should have received a copy of the GNU General Public License
13 # along with this program; if not, write to the Free Software
14 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
17 # Copyright © 2007 Pierre Habouzit
29 return (file => $name, line => 0, f => \*FILE);
37 sub stream_getline($) {
39 my $file = $stream->{f};
49 #{{{ file:line functions
52 my ($stream, $msg) = @_;
53 printf STDERR "%s:%d: %s\n", $stream->{file}, $stream->{line}, $msg;
59 return $h->{$k}{file}.':'.$h->{$k}{line};
64 printf "#line %d \"%s\"\n", $src->{line} + $inc, $src->{file};
72 my ($src, $type) = @_;
79 if (defined $types{$type}) {
80 my $pos = get_pos(\%types, $type);
81 fatal($src, "already defined type: `$type' at $pos");
84 while (stream_getline($src)) {
85 last if (/^\s*\}\s*;\s*/);
86 if (/^\s*\.(push|kind|ctype|dtor|ctor|check)\s*=\s*(.*?)\s*;\s*$/) {
89 if ($2 =~ /^'([bis])'$/) {
92 fatal($src, "error: .kind should be [ibs] got $2)");
96 fatal($src, "syntax error: unknown type directive");
100 for ('kind', 'ctype') {
101 fatal($src, "incomplete type $type: missing .$_") unless defined $t{$_};
103 if ($t{kind} eq 's') {
104 for ('dtor', 'ctor') {
105 fatal($src, "incomplete type $type: missing .$_") unless defined $t{$_};
108 unless (defined $t{check}) {
109 if ($t{kind} eq 'b') {
110 $t{check} = '(luaL_checkint($L, $$) == 0)';
113 if ($t{kind} eq 'i') {
114 $t{check} = 'luaL_checkint($L, $$)';
117 if ($t{kind} eq 's') {
118 $t{check} = 'luaL_checkstring($L, $$)';
122 $t{ctypefmt} .= ' %s' unless (($t{ctypefmt} = $t{ctype}) =~ s/:/ \%s :/);
123 $t{ctype} =~ s/:.*//;
125 return $types{$type} = \%t;
128 sub parse_package($$) {
129 my ($src, $pkg) = @_;
132 file => $src->{file},
133 line => $src->{line},
136 if (defined $pkgs{$pkg}) {
137 my $pos = get_pos(\%pkgs, $pkg);
138 fatal($src, "already defined package: `$pkg' at $pos");
141 while (stream_getline($src)) {
142 if (/^\s*\}\s*(\w+)\s*;\s*$/) {
147 if (/^\s*(.*?)\s*=\s*(.*?)\s*;\s*$/) {
148 my ($lhs, $rhs) = ($1, $2);
149 my %m = ( file => $src->{file}, line => $src->{line} );
151 if ($lhs =~ /^((?:const\s+)?\w+?)\s*(\w+)$/) {
155 push @{$p{props}}, $2;
156 } elsif ($lhs =~ /^((?:const\s+)?\w+?)\s*(\w*)\((.*)\)$/) {
161 push @{$p{meths}}, $2;
163 fatal($src, "syntax error");
166 if (defined $p{members}{$m{name}}) {
167 my $pos = get_pos($p{members}{$m{name}}, 0);
168 fatal($src, "already defined package member: `$m{name}' at $pos");
171 $p{members}{$m{name}} = \%m;
176 fatal($src, "syntax error");
180 return $pkgs{$pkg} = \%p;
184 my ($ref, $typ) = @_;
186 if ($typ =~ /^const\s+(\w*)$/) {
187 fatal($ref, "undefined type `$1'") unless defined $types{$1};
188 return (const => 1, type => $types{$1});
191 fatal($ref, "undefined type `$typ'") unless defined $types{$typ};
192 return (const => 0, type => $types{$typ});
201 my %t = find_type($f, $f->{type});
202 my $call = $f->{cfun};
205 print "static int luaM_${pkg}_$f->{name}(lua_State *L) {\n";
207 if ($f->{proto} ne "void") {
209 for my $tmp (split /,/,$f->{proto}) {
213 my %pt = find_type($f, $tmp);
214 my $check = $pt{type}->{check};
216 $check =~ s/\$\$/\%d/;
218 put_line($pt{type}, 0);
219 printf " $pt{type}->{ctype} var$i = $check\n", $i++;
223 if (defined $t{type}->{push}) {
224 $call =~ s/\$\$/$t{type}->{push}/;
227 if ($t{type}->{kind} eq 'b') {
229 print " lua_pushboolean(L, $call);\n";
232 if ($t{type}->{kind} eq 'i') {
234 print " lua_pushint(L, $call);\n";
237 if ($t{type}->{kind} eq 's') {
240 print " lua_pushstring(L, $call);\n";
244 print " char *s = $call;\n";
245 print " lua_pushstring(L, s);\n";
246 print " p_delete(&s);\n";
251 printf " return %d;\n", ($f->{type} ne "void");
259 sub dump_struct_full($) {
263 print "struct luaM_$pkg->{name}_t $pkg->{cname} = {\n";
265 foreach (@{$pkg->{props}}) {
266 my $p = $pkg->{members}{$_};
267 my %t = find_type($p, $p->{type});
271 print " $p->{init},\n";
273 print " 0,\n" if ($t{type}->{kind} eq 'b');
274 print " 0,\n" if ($t{type}->{kind} eq 'i');
275 print " NULL,\n" if ($t{type}->{kind} eq 's');
282 static void $pkg->{cname}_init(void)
286 foreach (@{$pkg->{props}}) {
287 my $p = $pkg->{members}{$_};
288 my %t = find_type($p, $p->{type});
289 my $var = $pkg->{cname}.".".$p->{name};
294 if ($t{type}->{dtor}) {
295 my $dtor = $t{type}->{dtor};
297 $dtor =~ s/\$\$/\&$var/;
300 print " $var = $p->{init};\n"
305 sub dump_struct_short($) {
308 print "struct luaM_$pkg->{name}_t {\n";
309 foreach (@{$pkg->{props}}) {
310 my $p = $pkg->{members}{$_};
311 my %t = find_type($p, $p->{type});
313 printf " const $t{type}->{ctypefmt};\n", $p->{name};
315 printf " $t{type}->{ctypefmt};\n", $p->{name};
322 extern struct luaM_$pkg->{name}_t $pkg->{cname};
326 sub dump_struct_static($) {
329 print "static struct {\n";
330 foreach (@{$pkg->{props}}) {
331 my $p = $pkg->{members}{$_};
332 my %t = find_type($p, $p->{type});
334 printf " const $t{type}->{ctypefmt};\n", $p->{name};
336 printf " $t{type}->{ctypefmt};\n", $p->{name};
340 print "} $pkg->{cname} = {\n";
342 foreach (@{$pkg->{props}}) {
343 my $p = $pkg->{members}{$_};
344 my %t = find_type($p, $p->{type});
348 print " $p->{init},\n";
350 print " 0,\n" if ($t{type}->{kind} eq 'b');
351 print " 0,\n" if ($t{type}->{kind} eq 'i');
352 print " NULL,\n" if ($t{type}->{kind} eq 's');
359 static void $pkg->{cname}_init(void)
363 foreach (@{$pkg->{props}}) {
364 my $p = $pkg->{members}{$_};
365 my %t = find_type($p, $p->{type});
366 my $var = $pkg->{cname}.".".$p->{name};
371 if ($t{type}->{dtor}) {
372 my $dtor = $t{type}->{dtor};
374 $dtor =~ s/\$\$/\&$var/;
377 print " $var = $p->{init};\n"
386 sub dump_package_full($$) {
387 my ($pkg, $static) = @_;
390 dump_struct_static($pkg);
392 dump_struct_full($pkg);
394 map { print "\n"; dump_fun($pkg->{name}, $pkg->{members}{$_}); } @{$pkg->{meths}};
397 static const luaL_reg luaM_$pkg->{name}_methods[] = {
399 map { print " { \"$_\", luaM_$pkg->{name}_$_ },\n"; } @{$pkg->{meths}};
404 static int luaM_$pkg->{name}_index(lua_State *L)
406 const char *idx = luaL_checkstring(L, 2);
408 switch (mlua_which_token(idx, -1)) {
411 foreach (@{$pkg->{props}}) {
412 my $p = $pkg->{members}{$_};
413 my %t = find_type($p, $p->{type});
414 my $call = $pkg->{cname}.".".$p->{name};
416 my $tok = $p->{name};
419 if ($t{type}->{kind} eq 'b') {
420 $call = "lua_pushboolean(L, $call)";
423 if ($t{type}->{kind} eq 'i') {
424 $call = "lua_pushinteger(L, $call)";
427 if ($t{type}->{kind} eq 's') {
428 $call = "lua_pushstring(L, $call)";
431 if (defined $t{type}->{push}) {
432 $call =~ s/\$\$/$t{type}->{push}/;
436 print " case LTK_$tok:\n";
438 print " return 1;\n";
443 lua_rawget(L, lua_upvalueindex(2)); /* try methods */
448 static int luaM_$pkg->{name}_newindex(lua_State *L)
450 const char *idx = luaL_checkstring(L, 2);
452 switch (mlua_which_token(idx, -1)) {
455 foreach (@{$pkg->{props}}) {
456 my $p = $pkg->{members}{$_};
457 my %t = find_type($p, $p->{type});
461 my $tok = $p->{name};
462 my $var = $pkg->{cname}.".".$p->{name};
463 my $check = $t{type}->{check};
469 print " case LTK_$tok: \n";
470 if ($t{type}->{dtor}) {
471 my $dtor = $t{type}->{dtor};
473 $dtor =~ s/\$\$/\&$var/;
476 if ($t{type}->{ctor}) {
477 my $ctor = $t{type}->{ctor};
479 $ctor =~ s/\$\$/$check/;
482 print " $var = $check;\n";
483 print " return 1;\n";
492 int luaopen_$pkg->{name}(lua_State *L)
496 $pkg->{cname}_init();
498 /* create methods table, add it the the table of globals */
499 luaL_openlib(L, "$pkg->{name}", luaM_$pkg->{name}_methods, 0);
500 methods = lua_gettop(L);
502 /* create metatable for $pkg->{name}, add it to the registry */
503 luaL_newmetatable(L, "$pkg->{name}");
506 lua_pushliteral(L, "__index");
507 lua_pushvalue(L, mt); /* upvalue 1 */
508 lua_pushvalue(L, methods); /* upvalue 2 */
509 lua_pushcclosure(L, &luaM_$pkg->{name}_index, 2);
510 lua_rawset(L, mt); /* set mt.__index */
512 lua_pushliteral(L, "__newindex");
513 lua_newtable(L); /* for new members */
514 lua_pushcclosure(L, &luaM_$pkg->{name}_newindex, 1);
515 lua_rawset(L, mt); /* set mt.__newindex */
517 lua_pushliteral(L, "__metatable");
518 lua_pushvalue(L, methods); /* dup methods table */
519 lua_rawset(L, mt); /* hide metatable */
521 lua_setmetatable(L, methods);
523 lua_pop(L, 1); /* drop mt */
524 return 1; /* return methods */
530 sub dump_package_short($) {
532 my $upp = $pkg->{name};
536 #ifndef MUTT_LUA_${upp}_H
537 #define MUTT_LUA_${upp}_H
540 dump_struct_short($pkg);
543 int luaopen_$pkg->{name}(lua_State *L);
545 #endif /* MUTT_LUA_${upp}_H */
552 my %src = stream_open(shift);
555 while (stream_getline(\%src)) {
556 if (/^\s*\@type\s+([a-zA-Z]\w*)\s*=\s*{\s*$/) {
557 parse_type(\%src, $1);
559 } elsif (/^\s*static\s+\@package\s+([a-zA-Z]\w*)\s+{\s*$/) {
560 dump_package_full(parse_package(\%src, $1), 1);
562 } elsif (/^\s*\@package\s+([a-zA-Z]\w*)\s+{\s*$/) {
563 dump_package_full(parse_package(\%src, $1), 0);
565 } elsif (/^\s*(\@\w*)/) {
566 fatal(\%src, "syntax error: unknown directive `$1'");
568 next if ($resync && /^\s+$/);
581 my %src = stream_open(shift);
584 while (stream_getline(\%src)) {
585 if (/^\s*\@type\s+([a-zA-Z]\w*)\s*=\s*{\s*$/) {
586 parse_type(\%src, $1);
587 } elsif (/^\s*\@package\s+([a-zA-Z]\w*)\s+{\s*$/) {
588 dump_package_short(parse_package(\%src, $1));
589 } elsif (/^\s*(\@\w*)/) {
590 fatal(\%src, "syntax error: unknown directive `$1'");
597 if ($#ARGV < 1 || ($ARGV[0] ne "-h" && $ARGV[0] ne "-c")) {
599 usage: mluapkg (-h | -c) file.pkg
605 /***** THIS FILE IS AUTOGENERATED DO NOT MODIFY DIRECTLY ! *****/
608 map { do_h($ARGV[$_]); } (1 .. $#ARGV) if ($ARGV[0] eq '-h');
609 map { do_c($ARGV[$_]); } (1 .. $#ARGV) if ($ARGV[0] eq '-c');