rx enhancements.
[apps/madmutt.git] / 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|dtor|ctor|check)\s*=\s*(.*?)\s*;\s*$/) {
87             $t{$1} = $2;
88             if ($1 eq "kind") {
89                 if ($2 =~ /^'([bis])'$/) {
90                     $t{kind} = $1;
91                 } else {
92                     fatal($src, "error: .kind should be [ibs] got $2)");
93                 }
94             }
95         } elsif (!/^\s*$/) {
96             fatal($src, "syntax error: unknown type directive");
97         }
98     }
99
100     for ('kind', 'ctype') {
101         fatal($src, "incomplete type $type: missing .$_") unless defined $t{$_};
102     }
103     if ($t{kind} eq 's') {
104         for ('dtor', 'ctor') {
105             fatal($src, "incomplete type $type: missing .$_") unless defined $t{$_};
106         }
107     }
108     unless (defined $t{check}) {
109         if ($t{kind} eq 'b') {
110             $t{check} = '(luaL_checkint($L, $$) == 0)';
111         }
112
113         if ($t{kind} eq 'i') {
114             $t{check} = 'luaL_checkint($L, $$)';
115         }
116
117         if ($t{kind} eq 's') {
118             $t{check} = 'luaL_checkstring($L, $$)';
119         }
120     }
121
122     $t{ctypefmt} .= ' %s' unless (($t{ctypefmt} = $t{ctype}) =~ s/:/ \%s :/);
123     $t{ctype} =~ s/:.*//;
124
125     return $types{$type} = \%t;
126 }
127
128 sub parse_package($$) {
129     my ($src, $pkg) = @_;
130     my %p = (
131         name => $pkg,
132         file => $src->{file},
133         line => $src->{line},
134     );
135
136     if (defined $pkgs{$pkg}) {
137         my $pos = get_pos(\%pkgs, $pkg);
138         fatal($src, "already defined package: `$pkg' at $pos");
139     }
140
141     while (stream_getline($src)) {
142         if (/^\s*\}\s*(\w+)\s*;\s*$/) {
143             $p{cname} = $1;
144             last;
145         }
146
147         if (/^\s*(.*?)\s*=\s*(.*?)\s*;\s*$/) {
148             my ($lhs, $rhs) = ($1, $2);
149             my %m = ( file => $src->{file}, line => $src->{line} );
150
151             if ($lhs =~ /^((?:const\s+)?\w+?)\s*(\w+)$/) {
152                 $m{type} = $1;
153                 $m{name} = $2;
154                 $m{init} = $rhs;
155                 push @{$p{props}}, $2;
156             } elsif ($lhs =~ /^((?:const\s+)?\w+?)\s*(\w*)\((.*)\)$/) {
157                 $m{type}  = $1;
158                 $m{name}  = $2;
159                 $m{proto} = $3;
160                 $m{cfun}  = $rhs;
161                 push @{$p{meths}}, $2;
162             } else {
163                 fatal($src, "syntax error");
164             }
165
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");
169             }
170
171             $p{members}{$m{name}} = \%m;
172             next;
173         }
174
175         if (!/^\s*$/) {
176             fatal($src, "syntax error");
177         }
178     }
179
180     return $pkgs{$pkg} = \%p;
181 }
182
183 sub find_type($$) {
184     my ($ref, $typ) = @_;
185
186     if ($typ =~ /^const\s+(\w*)$/) {
187         fatal($ref, "undefined type `$1'") unless defined $types{$1};
188         return (const => 1, type => $types{$1});
189     }
190
191     fatal($ref, "undefined type `$typ'") unless defined $types{$typ};
192     return (const => 0, type => $types{$typ});
193 }
194
195 #}}}
196
197 #{{{ dump_fun
198
199 sub dump_fun($$) {
200     my ($pkg, $f) = @_;
201     my %t    = find_type($f, $f->{type});
202     my $call = $f->{cfun};
203     $call =~ s/\$/var/;
204
205     print "static int luaM_${pkg}_$f->{name}(lua_State *L) {\n";
206
207     if ($f->{proto} ne "void") {
208         my $i = 1;
209         for my $tmp (split /,/,$f->{proto}) {
210             s/^\s+//;
211             s/\s+$//;
212
213             my %pt = find_type($f, $tmp);
214             my $check = $pt{type}->{check};
215             $check =~ s/\$L/L/;
216             $check =~ s/\$\$/\%d/;
217
218             put_line($pt{type}, 0);
219             printf "    $pt{type}->{ctype} var$i = $check\n", $i++;
220         }
221     }
222
223     if (defined $t{type}->{push}) {
224         $call =~ s/\$\$/$t{type}->{push}/;
225     }
226
227     if ($t{type}->{kind} eq 'b') {
228         put_line($f, 0);
229         print "    lua_pushboolean(L, $call);\n";
230     }
231
232     if ($t{type}->{kind} eq 'i') {
233         put_line($f, 0);
234         print "    lua_pushint(L, $call);\n";
235     }
236
237     if ($t{type}->{kind} eq 's') {
238         if ($t{const}) {
239             put_line($f, 0);
240             print "    lua_pushstring(L, $call);\n";
241         } else {
242             print "    {\n";
243             put_line($f, 0);
244             print "        char *s = $call;\n";
245             print "        lua_pushstring(L, s);\n";
246             print "        p_delete(&s);\n";
247             print "    }\n";
248         }
249     }
250
251     printf "    return %d;\n", ($f->{type} ne "void");
252     print "}\n";
253 }
254
255 #}}}
256
257 #{{{ dump_struct
258
259 sub dump_struct_full($) {
260     my ($pkg) = @_;
261
262     put_line($pkg, 0);
263     print "struct luaM_$pkg->{name}_t $pkg->{cname} = {\n";
264
265     foreach (@{$pkg->{props}}) {
266         my $p = $pkg->{members}{$_};
267         my %t = find_type($p, $p->{type});
268
269         if ($t{const}) {
270             put_line($p, 0);
271             print "    $p->{init},\n";
272         } else {
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');
276         }
277     }
278
279     print <<EOF;
280 };
281
282 static void $pkg->{cname}_init(void)
283 {
284 EOF
285
286     foreach (@{$pkg->{props}}) {
287         my $p   = $pkg->{members}{$_};
288         my %t   = find_type($p, $p->{type});
289         my $var = $pkg->{cname}.".".$p->{name};
290
291         next if $t{const};
292
293         put_line($p, 0);
294         if ($t{type}->{dtor}) {
295             my $dtor = $t{type}->{dtor};
296             $dtor =~ s/\$L/L/;
297             $dtor =~ s/\$\$/\&$var/;
298             print "    $dtor;\n";
299         }
300         print "    $var = $p->{init};\n"
301     }
302     print "};\n";
303 };
304
305 sub dump_struct_short($) {
306     my ($pkg) = @_;
307
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});
312         if ($t{const}) {
313             printf "    const $t{type}->{ctypefmt};\n", $p->{name};
314         } else {
315             printf "    $t{type}->{ctypefmt};\n", $p->{name};
316         }
317     }
318     put_line($pkg, 0);
319     print <<EOF;
320 };
321
322 extern struct luaM_$pkg->{name}_t $pkg->{cname};
323 EOF
324 }
325
326 sub dump_struct_static($) {
327     my ($pkg) = @_;
328
329     print "static struct {\n";
330     foreach (@{$pkg->{props}}) {
331         my $p = $pkg->{members}{$_};
332         my %t = find_type($p, $p->{type});
333         if ($t{const}) {
334             printf "    const $t{type}->{ctypefmt};\n", $p->{name};
335         } else {
336             printf "    $t{type}->{ctypefmt};\n", $p->{name};
337         }
338     }
339     put_line($pkg, 0);
340     print "} $pkg->{cname} = {\n";
341
342     foreach (@{$pkg->{props}}) {
343         my $p = $pkg->{members}{$_};
344         my %t = find_type($p, $p->{type});
345
346         if ($t{const}) {
347             put_line($p, 0);
348             print "    $p->{init},\n";
349         } else {
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');
353         }
354     }
355
356     print <<EOF;
357 };
358
359 static void $pkg->{cname}_init(void)
360 {
361 EOF
362
363     foreach (@{$pkg->{props}}) {
364         my $p   = $pkg->{members}{$_};
365         my %t   = find_type($p, $p->{type});
366         my $var = $pkg->{cname}.".".$p->{name};
367
368         next if $t{const};
369
370         put_line($p, 0);
371         if ($t{type}->{dtor}) {
372             my $dtor = $t{type}->{dtor};
373             $dtor =~ s/\$L/L/;
374             $dtor =~ s/\$\$/\&$var/;
375             print "    $dtor;\n";
376         }
377         print "    $var = $p->{init};\n"
378     }
379     print "};\n";
380 };
381
382 #}}}
383
384 #{{{ dump package
385
386 sub dump_package_full($$) {
387     my ($pkg, $static) = @_;
388
389     if ($static) {
390         dump_struct_static($pkg);
391     } else {
392         dump_struct_full($pkg);
393     }
394     map { print "\n"; dump_fun($pkg->{name}, $pkg->{members}{$_}); } @{$pkg->{meths}};
395     print <<EOF;
396
397 static const luaL_reg luaM_$pkg->{name}_methods[] = {
398 EOF
399     map { print "    { \"$_\", luaM_$pkg->{name}_$_ },\n"; } @{$pkg->{meths}};
400     print <<EOF;
401     { NULL, NULL }
402 };
403
404 static int luaM_$pkg->{name}_index(lua_State *L)
405 {
406     const char *idx = luaL_checkstring(L, 2);
407
408     switch (mlua_which_token(idx, -1)) {
409 EOF
410
411     foreach (@{$pkg->{props}}) {
412         my $p = $pkg->{members}{$_};
413         my %t = find_type($p, $p->{type});
414         my $call = $pkg->{cname}.".".$p->{name};
415
416         my $tok = $p->{name};
417         $tok =~ tr/a-z/A-Z/;
418
419         if ($t{type}->{kind} eq 'b') {
420             $call = "lua_pushboolean(L, $call)";
421         }
422
423         if ($t{type}->{kind} eq 'i') {
424             $call = "lua_pushinteger(L, $call)";
425         }
426
427         if ($t{type}->{kind} eq 's') {
428             $call = "lua_pushstring(L, $call)";
429         }
430
431         if (defined $t{type}->{push}) {
432             $call =~ s/\$\$/$t{type}->{push}/;
433         }
434
435         put_line($p, 0);
436         print  "      case LTK_$tok:\n";
437         printf "        $call;\n";
438         print  "        return 1;\n";
439     }
440
441 print <<EOF;
442       default:
443         lua_rawget(L, lua_upvalueindex(2));       /* try methods       */
444         return 1;
445     }
446 }
447
448 static int luaM_$pkg->{name}_newindex(lua_State *L)
449 {
450     const char *idx = luaL_checkstring(L, 2);
451
452     switch (mlua_which_token(idx, -1)) {
453 EOF
454
455     foreach (@{$pkg->{props}}) {
456         my $p = $pkg->{members}{$_};
457         my %t = find_type($p, $p->{type});
458
459         next if ($t{const});
460
461         my $tok = $p->{name};
462         my $var = $pkg->{cname}.".".$p->{name};
463         my $check = $t{type}->{check};
464         $tok   =~ tr/a-z/A-Z/;
465         $check =~ s/\$L/L/;
466         $check =~ s/\$\$/3/;
467
468         put_line($p, 0);
469         print  "      case LTK_$tok: \n";
470         if ($t{type}->{dtor}) {
471             my $dtor = $t{type}->{dtor};
472             $dtor =~ s/\$L/L/;
473             $dtor =~ s/\$\$/\&$var/;
474             print "        $dtor;\n";
475         }
476         if ($t{type}->{ctor}) {
477             my $ctor = $t{type}->{ctor};
478             $ctor =~ s/\$L/L/;
479             $ctor =~ s/\$\$/$check/;
480             $check = $ctor;
481         }
482         print "        $var = $check;\n";
483         print "        return 1;\n";
484     }
485
486 print <<EOF;
487       default:
488         return 1;
489     }
490 }
491
492 int luaopen_$pkg->{name}(lua_State *L)
493 {
494     int mt, methods;
495
496     $pkg->{cname}_init();
497
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);
501
502     /* create metatable for $pkg->{name}, add it to the registry */
503     luaL_newmetatable(L, "$pkg->{name}");
504     mt = lua_gettop(L);
505
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    */
511
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 */
516
517     lua_pushliteral(L, "__metatable");
518     lua_pushvalue(L, methods);                  /* dup methods table */
519     lua_rawset(L, mt);                          /* hide metatable    */
520
521     lua_setmetatable(L, methods);
522
523     lua_pop(L, 1);                              /* drop mt           */
524     return 1;                                   /* return methods    */
525 }
526
527 EOF
528 }
529
530 sub dump_package_short($) {
531     my $pkg = shift;
532     my $upp = $pkg->{name};
533     $upp =~ tr/a-z/A-Z/;
534
535     print <<EOF;
536 #ifndef MUTT_LUA_${upp}_H
537 #define MUTT_LUA_${upp}_H
538
539 EOF
540     dump_struct_short($pkg);
541     print <<EOF
542
543 int luaopen_$pkg->{name}(lua_State *L);
544
545 #endif /* MUTT_LUA_${upp}_H */
546 EOF
547 }
548
549 #}}}
550
551 sub do_c($) {
552     my %src = stream_open(shift);
553     my $resync = 1;
554
555     while (stream_getline(\%src)) {
556         if (/^\s*\@type\s+([a-zA-Z]\w*)\s*=\s*{\s*$/) {
557             parse_type(\%src, $1);
558             $resync = 1;
559         } elsif (/^\s*static\s+\@package\s+([a-zA-Z]\w*)\s+{\s*$/) {
560             dump_package_full(parse_package(\%src, $1), 1);
561             $resync = 1;
562         } elsif (/^\s*\@package\s+([a-zA-Z]\w*)\s+{\s*$/) {
563             dump_package_full(parse_package(\%src, $1), 0);
564             $resync = 1;
565         } elsif (/^\s*(\@\w*)/) {
566             fatal(\%src, "syntax error: unknown directive `$1'");
567         } else {
568             next if ($resync && /^\s+$/);
569             if ($resync) {
570                 put_line(\%src, 0);
571                 $resync = 0;
572             }
573             print;
574         }
575     }
576
577     stream_close(\%src);
578 }
579
580 sub do_h($) {
581     my %src = stream_open(shift);
582     my $resync = 1;
583
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'");
591         }
592     }
593
594     stream_close(\%src);
595 }
596
597 if ($#ARGV < 1 || ($ARGV[0] ne "-h" && $ARGV[0] ne "-c")) {
598     print <<EOF;
599 usage: mluapkg (-h | -c) file.pkg
600 EOF
601     exit 1;
602 }
603
604 print <<EOF;
605 /*****     THIS FILE IS AUTOGENERATED DO NOT MODIFY DIRECTLY !    *****/
606 EOF
607
608 map { do_h($ARGV[$_]); } (1 .. $#ARGV) if ($ARGV[0] eq '-h');
609 map { do_c($ARGV[$_]); } (1 .. $#ARGV) if ($ARGV[0] eq '-c');