lib-lua/luapkg2c.pl

   1 #!/usr/bin/perl -w
   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.
   6 #
   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.
  11 #
  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,
  15 #  MA 02110-1301, USA.
  16 #
  17 #  Copyright © 2007 Pierre Habouzit
  18
  19 use strict;
  20
  21 my %types;
  22 my %pkgs;
  23
  24 #{{{ stream functions
  25
  26 sub stream_open($) {
  27     my $name = shift;
  28     open FILE, $name;
  29     return (file => $name, line => 0, f => \*FILE);
  30 }
  31
  32 sub stream_close($) {
  33     my $stream = shift;
  34     close $stream->{f};
  35 }
  36
  37 sub stream_getline($) {
  38     my $stream = shift;
  39     my $file   = $stream->{f};
  40     while (<$file>) {
  41         ${$stream}{line}++;
  42         return $_;
  43     }
  44     return;
  45 }
  46
  47 #}}}
  48
  49 #{{{ file:line functions
  50
  51 sub fatal($$) {
  52     my ($stream, $msg) = @_;
  53     printf STDERR "%s:%d: %s\n", $stream->{file}, $stream->{line}, $msg;
  54     exit 1;
  55 }
  56
  57 sub get_pos($$) {
  58     my ($h,$k) = @_;
  59     return $h->{$k}{file}.':'.$h->{$k}{line};
  60 }
  61
  62 sub put_line($$) {
  63     my ($src,$inc) = @_;
  64     printf "#line %d \"%s\"\n", $src->{line} + $inc, $src->{file};
  65 }
  66
  67 #}}}
  68
  69 #{{{ parsers
  70
  71 sub parse_type($$) {
  72     my ($src, $type) = @_;
  73     my %t = (
  74         name => $type,
  75         file => $src->{file},
  76         line => $src->{line},
  77     );
  78
  79     if (defined $types{$type}) {
  80         my $pos = get_pos(\%types, $type);
  81         fatal($src, "already defined type: `$type' at $pos");
  82     }
  83
  84     while (stream_getline($src)) {
  85         last if (/^\s*\}\s*;\s*/);
  86         if (/^\s*\.(push|kind|ctype|check)\s*=\s*(.*?)\s*;\s*$/) {
  87             $t{$1} = $2;
  88             if ($1 eq "kind") {
  89                 if ($2 =~ /^'([si])'$/) {
  90                     $t{kind} = $1;
  91                 } else {
  92                     fatal($src, "error: .kind should be 'i' or 's' got $2)");
  93                 }
  94             }
  95         } elsif (!/^\s*$/) {
  96             fatal($src, "syntax error: unknown type directive");
  97         }
  98     }
  99
 100     for my $i ('kind', 'ctype') {
 101         fatal($src, "incomplete type $type: missing .$i") unless defined $t{$i};
 102     }
 103     unless (defined $t{check}) {
 104         if ($t{kind} eq 's') {
 105             $t{check} = 'luaL_checkstring($L, $$)';
 106         }
 107
 108         if ($t{kind} eq 'i') {
 109             $t{check} = 'luaL_checkint($l, $$)';
 110         }
 111     }
 112
 113     return $types{$type} = \%t;
 114 }
 115
 116 sub parse_package($$) {
 117     my ($src, $pkg) = @_;
 118     my %p = (
 119         name => $pkg,
 120         file => $src->{file},
 121         line => $src->{line},
 122     );
 123
 124     if (defined $pkgs{$pkg}) {
 125         my $pos = get_pos(\%pkgs, $pkg);
 126         fatal($src, "already defined package: `$pkg' at $pos");
 127     }
 128
 129     while (stream_getline($src)) {
 130         if (/^\s*\}\s*(\w+)\s*;\s*$/) {
 131             $p{cname} = $1;
 132             last;
 133         }
 134
 135         if (/^\s*(.*?)\s*=\s*(.*?)\s*;\s*$/) {
 136             my ($lhs, $rhs) = ($1, $2);
 137             my %m = ( file => $src->{file}, line => $src->{line} );
 138
 139             if ($lhs =~ /^((?:const\s+)?\w+?)\s*(\w+)$/) {
 140                 $m{type} = $1;
 141                 $m{name} = $2;
 142                 $m{init} = $rhs;
 143                 push @{$p{props}}, $2;
 144             } elsif ($lhs =~ /^((?:const\s+)?\w+?)\s*(\w*)\((.*)\)$/) {
 145                 $m{type}  = $1;
 146                 $m{name}  = $2;
 147                 $m{proto} = $3;
 148                 $m{cfun}  = $rhs;
 149                 push @{$p{meths}}, $2;
 150             } else {
 151                 fatal($src, "syntax error");
 152             }
 153
 154             if (defined $p{members}{$m{name}}) {
 155                 my $pos = get_pos($p{members}{$m{name}}, 0);
 156                 fatal($src, "already defined package member: `$m{name}' at $pos");
 157             }
 158
 159             $p{members}{$m{name}} = \%m;
 160             next;
 161         }
 162
 163         if (!/^\s*$/) {
 164             fatal($src, "syntax error");
 165         }
 166     }
 167
 168     return $pkgs{$pkg} = \%p;
 169 }
 170
 171 sub find_type($$) {
 172     my ($ref, $typ) = @_;
 173
 174     if ($typ =~ /^const\s+(\w*)$/) {
 175         fatal($ref, "undefined type `$1'") unless defined $types{$1};
 176         return (const => 1, type => $types{$1});
 177     }
 178
 179     fatal($ref, "undefined type `$typ'") unless defined $types{$typ};
 180     return (const => 0, type => $types{$typ});
 181 }
 182
 183 #}}}
 184
 185 #{{{ dump_fun
 186
 187 sub dump_fun($$) {
 188     my ($pkg, $f) = @_;
 189     my %t    = find_type($f, $f->{type});
 190     my $call = $f->{cfun};
 191     $call =~ s/\$/var/;
 192
 193     print "static int luaM_${pkg}_$f->{name}(lua_State *L) {\n";
 194
 195     if ($f->{proto} ne "void") {
 196         my $i = 1;
 197         for my $tmp (split /,/,$f->{proto}) {
 198             s/^\s+//;
 199             s/\s+$//;
 200
 201             my %pt = find_type($f, $tmp);
 202             my $check = $pt{type}->{check};
 203             $check =~ s/\$L/L/;
 204             $check =~ s/\$\$/\%d/;
 205
 206             put_line($pt{type}, 0);
 207             printf "    $pt{type}->{ctype} var$i = $check\n", $i++;
 208         }
 209     }
 210
 211     if (defined $t{type}->{push}) {
 212         $call =~ s/\$\$/$t{type}->{push}/;
 213     }
 214
 215     if ($t{type}->{kind} eq 's') {
 216         if ($t{const}) {
 217             put_line($f, 0);
 218             print "    lua_pushstring(L, $call);\n";
 219         } else {
 220             print "    {\n";
 221             put_line($f, 0);
 222             print "        char *s = $call;\n";
 223             print "        lua_pushstring(L, s);\n";
 224             print "        p_delete(&s);\n";
 225             print "    }\n";
 226         }
 227     }
 228
 229     if ($t{type}->{kind} eq 'i') {
 230         put_line($f, 0);
 231         print "    lua_pushint(L, $call);\n";
 232     }
 233
 234     printf "    return %d;\n", ($f->{type} ne "void");
 235     print "}\n";
 236 }
 237
 238 #}}}
 239
 240 #{{{ dump_struct
 241
 242 sub dump_struct_full($) {
 243     my ($pkg) = @_;
 244
 245     put_line($pkg, 0);
 246     print "struct luaM_$pkg->{name}_t $pkg->{cname} = {\n";
 247
 248     foreach (@{$pkg->{props}}) {
 249         my $p = $pkg->{members}{$_};
 250         my %t = find_type($p, $p->{type});
 251
 252         if ($t{const}) {
 253             put_line($p, 0);
 254             print "    $p->{init},\n";
 255         } else {
 256             print "    0,\n"    if ($t{type}->{kind} eq 'i');
 257             print "    NULL,\n" if ($t{type}->{kind} eq 's');
 258         }
 259     }
 260
 261     print <<EOF;
 262 };
 263
 264 static void $pkg->{cname}_init(void)
 265 {
 266 EOF
 267
 268     foreach (@{$pkg->{props}}) {
 269         my $p   = $pkg->{members}{$_};
 270         my %t   = find_type($p, $p->{type});
 271         my $var = $pkg->{cname}.".".$p->{name};
 272
 273         next if $t{const};
 274
 275         put_line($p, 0);
 276         print "        m_strreplace(&$var, $p->{init});\n" if ($t{type}->{kind} eq 's');
 277         print "        $var = $p->{init};\n"               if ($t{type}->{kind} eq 'i');
 278     }
 279     print "};\n";
 280 };
 281
 282 sub dump_struct_short($) {
 283     my ($pkg) = @_;
 284
 285     print "struct luaM_$pkg->{name}_t {\n";
 286     foreach (@{$pkg->{props}}) {
 287         my $p = $pkg->{members}{$_};
 288         my %t = find_type($p, $p->{type});
 289         print "    $t{type}->{ctype} $p->{name};\n";
 290     }
 291     put_line($pkg, 0);
 292     print <<EOF;
 293 };
 294
 295 extern struct luaM_$pkg->{name}_t $pkg->{cname};
 296 EOF
 297 }
 298
 299 #}}}
 300
 301 #{{{ dump package
 302
 303 sub dump_package_full($) {
 304     my $pkg = shift;
 305
 306     dump_struct_full($pkg);
 307     map { print "\n"; dump_fun($pkg->{name}, $pkg->{members}{$_}); } @{$pkg->{meths}};
 308     print <<EOF;
 309
 310 static const luaL_reg luaM_$pkg->{name}_methods[] = {
 311 EOF
 312     map { print "    { \"$_\", luaM_$pkg->{name}_$_ },\n"; } @{$pkg->{meths}};
 313     print <<EOF;
 314     { NULL, NULL }
 315 };
 316
 317 static int luaM_$pkg->{name}_index(lua_State *L)
 318 {
 319     const char *idx = luaL_checkstring(L, 2);
 320
 321     switch (mlua_which_token(idx, -1)) {
 322 EOF
 323
 324     foreach (@{$pkg->{props}}) {
 325         my $p = $pkg->{members}{$_};
 326         my %t = find_type($p, $p->{type});
 327         my $call = $pkg->{cname}.".".$p->{name};
 328
 329         my $tok = $p->{name};
 330         $tok =~ tr/a-z/A-Z/;
 331
 332         if ($t{type}->{kind} eq 's') {
 333             $call = "lua_pushstring(L, $call)";
 334         }
 335
 336         if ($t{type}->{kind} eq 'i') {
 337             $call = "lua_pushinteger(L, $call)";
 338         }
 339
 340         if (defined $t{type}->{push}) {
 341             $call =~ s/\$\$/$t{type}->{push}/;
 342         }
 343
 344         put_line($p, 0);
 345         print  "      case LTK_$tok:\n";
 346         printf "        $call;\n";
 347         print  "        return 1;\n";
 348     }
 349
 350 print <<EOF;
 351       default:
 352         lua_rawget(L, lua_upvalueindex(2));       /* try methods       */
 353         return 1;
 354     }
 355 }
 356
 357 static int luaM_$pkg->{name}_newindex(lua_State *L)
 358 {
 359     const char *idx = luaL_checkstring(L, 2);
 360
 361     switch (mlua_which_token(idx, -1)) {
 362 EOF
 363
 364     foreach (@{$pkg->{props}}) {
 365         my $p = $pkg->{members}{$_};
 366         my %t = find_type($p, $p->{type});
 367
 368         next if ($t{const});
 369
 370         my $tok = $p->{name};
 371         my $var = $pkg->{cname}.".".$p->{name};
 372         my $check = $t{type}->{check};
 373         $tok   =~ tr/a-z/A-Z/;
 374         $check =~ s/\$L/L/;
 375         $check =~ s/\$\$/3/;
 376
 377         put_line($p, 0);
 378         print  "      case LTK_$tok: \n";
 379         print "        m_strreplace(&$var, $check)" if ($t{type}->{kind} eq 's');
 380         print "        $var = $check"               if ($t{type}->{kind} eq 'i');
 381
 382         print  ";\n        return 1;\n";
 383     }
 384
 385 print <<EOF;
 386       default:
 387         return 1;
 388     }
 389 }
 390
 391 int luaopen_$pkg->{name}(lua_State *L)
 392 {
 393     int mt, methods;
 394
 395     $pkg->{cname}_init();
 396
 397     /* create methods table, add it the the table of globals */
 398     luaL_openlib(L, "$pkg->{name}", luaM_$pkg->{name}_methods, 0);
 399     methods = lua_gettop(L);
 400
 401     /* create metatable for $pkg->{name}, add it to the registry */
 402     luaL_newmetatable(L, "$pkg->{name}");
 403     mt = lua_gettop(L);
 404
 405     lua_pushliteral(L, "__index");
 406     lua_pushvalue(L, mt);                       /* upvalue 1         */
 407     lua_pushvalue(L, methods);                  /* upvalue 2         */
 408     lua_pushcclosure(L, &luaM_$pkg->{name}_index, 2);
 409     lua_rawset(L, mt);                          /* set mt.__index    */
 410
 411     lua_pushliteral(L, "__newindex");
 412     lua_newtable(L);                            /* for new members   */
 413     lua_pushcclosure(L, &luaM_$pkg->{name}_newindex, 1);
 414     lua_rawset(L, mt);                          /* set mt.__newindex */
 415
 416     lua_pushliteral(L, "__metatable");
 417     lua_pushvalue(L, methods);                  /* dup methods table */
 418     lua_rawset(L, mt);                          /* hide metatable    */
 419
 420     lua_setmetatable(L, methods);
 421
 422     lua_pop(L, 1);                              /* drop mt           */
 423     return 1;                                   /* return methods    */
 424 }
 425
 426 EOF
 427 }
 428
 429 sub dump_package_short($) {
 430     my $pkg = shift;
 431     my $upp = $pkg->{name};
 432     $upp =~ tr/a-z/A-Z/;
 433
 434     print <<EOF;
 435 #ifndef MUTT_LUA_${upp}_H
 436 #define MUTT_LUA_${upp}_H
 437
 438 EOF
 439     dump_struct_short($pkg);
 440     print <<EOF
 441
 442 int luaopen_$pkg->{name}(lua_State *L);
 443
 444 #endif /* MUTT_LUA_${upp}_H */
 445 EOF
 446 }
 447
 448 #}}}
 449
 450 sub do_c($) {
 451     my %src = stream_open(shift);
 452     my $resync = 1;
 453
 454     while (stream_getline(\%src)) {
 455         if (/^\s*\@type\s+([a-zA-Z]\w*)\s*=\s*{\s*$/) {
 456             parse_type(\%src, $1);
 457             $resync = 1;
 458         } elsif (/^\s*\@package\s+([a-zA-Z]\w*)\s+{\s*$/) {
 459             dump_package_full(parse_package(\%src, $1));
 460             $resync = 1;
 461         } elsif (/^\s*(\@\w*)/) {
 462             fatal(\%src, "syntax error: unknown directive `$1'");
 463         } else {
 464             next if ($resync && /^\s+$/);
 465             if ($resync) {
 466                 put_line(\%src, 0);
 467                 $resync = 0;
 468             }
 469             print;
 470         }
 471     }
 472     print "/* vi"."m:set ft=c: */\n";
 473
 474     stream_close(\%src);
 475 }
 476
 477 sub do_h($) {
 478     my %src = stream_open(shift);
 479     my $resync = 1;
 480
 481     while (stream_getline(\%src)) {
 482         if (/^\s*\@type\s+([a-zA-Z]\w*)\s*=\s*{\s*$/) {
 483             parse_type(\%src, $1);
 484         } elsif (/^\s*\@package\s+([a-zA-Z]\w*)\s+{\s*$/) {
 485             dump_package_short(parse_package(\%src, $1));
 486         } elsif (/^\s*(\@\w*)/) {
 487             fatal(\%src, "syntax error: unknown directive `$1'");
 488         }
 489     }
 490
 491     stream_close(\%src);
 492 }
 493
 494 if ($#ARGV < 1 || ($ARGV[0] ne "-h" && $ARGV[0] ne "-c")) {
 495     print <<EOF;
 496 usage: mluapkg (-h | -c) file.pkg
 497 EOF
 498     exit 1;
 499 }
 500
 501 print <<EOF;
 502 /*****     THIS FILE IS AUTOGENERATED DO NOT MODIFY DIRECTLY !    *****/
 503 EOF
 504
 505 map { do_h($ARGV[$_]); } (1 .. $#ARGV) if ($ARGV[0] eq '-h');
 506 map { do_c($ARGV[$_]); } (1 .. $#ARGV) if ($ARGV[0] eq '-c');