| 1 | #! perl |
1 | #! perl |
| 2 | |
2 | |
| 3 | # actually geninterface |
3 | # |
|
|
4 | # This file is part of Deliantra, the Roguelike Realtime MMORPG. |
|
|
5 | # |
|
|
6 | # Copyright (©) 2005,2006,2007,2008,2009 Marc Alexander Lehmann / Robin Redeker / the Deliantra team |
|
|
7 | # |
|
|
8 | # Deliantra is free software: you can redistribute it and/or modify it under |
|
|
9 | # the terms of the Affero GNU General Public License as published by the |
|
|
10 | # Free Software Foundation, either version 3 of the License, or (at your |
|
|
11 | # option) any later version. |
|
|
12 | # |
|
|
13 | # This program is distributed in the hope that it will be useful, |
|
|
14 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
|
15 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
|
16 | # GNU General Public License for more details. |
|
|
17 | # |
|
|
18 | # You should have received a copy of the Affero GNU General Public License |
|
|
19 | # and the GNU General Public License along with this program. If not, see |
|
|
20 | # <http://www.gnu.org/licenses/>. |
|
|
21 | # |
|
|
22 | # The authors can be reached via e-mail to <support@deliantra.net> |
|
|
23 | # |
|
|
24 | |
|
|
25 | # used to automatically create accessors/mutators and method interfaces |
|
|
26 | # to C++ classes for Perl. |
|
|
27 | # also write data structures as JSON object, for reflection |
|
|
28 | |
|
|
29 | use JSON::XS; |
| 4 | |
30 | |
| 5 | my $class = shift; |
31 | my $class = shift; |
| 6 | my $curclass = ""; |
32 | my $curclass = ""; |
| 7 | my (@scalar_member, @array_member); |
33 | my (@scalar_member, @array_member); |
| 8 | |
34 | |
|
|
35 | # convert c member name to perl |
|
|
36 | sub c2perl($) { |
|
|
37 | local $_ = shift; |
|
|
38 | |
|
|
39 | s/^([^.]+)\.\1_/$1\_/g; # tcpi.tcpi_xxx => tcpi_xxx |
|
|
40 | |
|
|
41 | $_ |
|
|
42 | } |
|
|
43 | |
| 9 | for my $file (@ARGV) { |
44 | for my $file (@ARGV) { |
| 10 | open my $fh, "<:utf8", $file |
45 | open my $fh, "<:utf8", $file |
| 11 | or die "$file: $!"; |
46 | or die "$file: $!"; |
| 12 | |
47 | |
| 13 | while (<$fh>) { |
48 | while (<$fh>) { |
|
|
49 | next if /^\s*\//; # skip lines starting with / |
| 14 | if ($curclass eq $class) { |
50 | if ($curclass eq $class) { |
| 15 | while (/ACC\s*\(R([WO])\s*,\s*([^)\]]+)(?:\[(\S+)\])?\)/g) { |
51 | while (/ACC\s*\(R([WO])\s*,\s*([^)\]]+)(?:\[(\S+)\])?\)/g) { |
|
|
52 | my ($access, $name, $count) = ($1, $2, $3); |
|
|
53 | my $static = /\bstatic\b/; |
| 16 | if ($3) { |
54 | if ($count) { |
|
|
55 | die "static array members not yet supported by genacc" if $static; |
| 17 | push @array_member, [$1, $2, $3]; |
56 | push @array_member, [$access, $name, $static, $count]; |
| 18 | } else { |
57 | } else { |
| 19 | push @scalar_member, [$1, $2]; |
58 | push @scalar_member, [$access, $name, $static]; |
| 20 | } |
59 | } |
| 21 | } |
60 | } |
| 22 | if (/MTH \s+ ([^(]*?) \s* ([A-Za-z_0-9]+) \s* \(([^)]*)\)/x) { |
61 | if (/MTH \s+ ([^(]*?) \s* ([A-Za-z_0-9]+) \s* \(([^)]*)\)/x) { |
|
|
62 | my ($retval, $name, $args) = ($1, $2, $3); |
| 23 | push @method_member, [$1, $2, $3]; |
63 | push @method_member, [$retval, $name, $args]; |
| 24 | } |
64 | } |
| 25 | } |
65 | } |
| 26 | while (/INTERFACE_CLASS\s*\((\S+)\)/g) { |
66 | while (/INTERFACE_CLASS\s*\((\S+)\)/g) { |
| 27 | $curclass = $1; |
67 | $curclass = $1; |
| 28 | } |
68 | } |
| … | |
… | |
| 50 | } |
90 | } |
| 51 | |
91 | |
| 52 | print "\n"; |
92 | print "\n"; |
| 53 | } |
93 | } |
| 54 | |
94 | |
| 55 | if (@scalar_member) { |
95 | for my $static (0, 1) { |
|
|
96 | my @member = grep $static == $_->[2], @scalar_member; |
|
|
97 | |
|
|
98 | if (@member) { |
|
|
99 | my $self; |
|
|
100 | if ($static) { |
|
|
101 | $self = "$class\::"; |
|
|
102 | print "SV *$member[0][1] (SV *newval = 0)\n", |
|
|
103 | "\tPROTOTYPE: ;\$\n"; |
|
|
104 | } else { |
|
|
105 | $self = "self->"; |
| 56 | print "SV *$scalar_member[0][1] ($class *self, SV *newval = 0)\n"; |
106 | print "SV *$member[0][1] ($class *self, SV *newval = 0)\n", |
|
|
107 | "\tPROTOTYPE: \$;\$\n"; |
|
|
108 | } |
|
|
109 | |
|
|
110 | if (@member > 1) { |
|
|
111 | print "\tALIAS:\n"; |
|
|
112 | for (1 .. $#member) { |
|
|
113 | print "\t\t" . (c2perl $member[$_][1]) . "\t= $_\n"; |
|
|
114 | } |
|
|
115 | } |
|
|
116 | |
|
|
117 | print "\tCODE:\n"; |
|
|
118 | |
|
|
119 | my $ix = @member == 1 ? 0 : "ix"; |
|
|
120 | |
|
|
121 | # read |
|
|
122 | print "\tif (GIMME_V == G_VOID)\n", |
|
|
123 | "\t RETVAL = &PL_sv_undef;\n", |
|
|
124 | "\telse\n", |
|
|
125 | "\t switch ($ix)\n", |
|
|
126 | "\t {\n", |
|
|
127 | (map "\t case $_: RETVAL = to_sv ($self$member[$_][1]); break;\n", |
|
|
128 | 0 .. $#member), |
|
|
129 | "\t default: croak (\"scalar_member is write-only\");\n", |
|
|
130 | "\t };\n"; |
|
|
131 | |
|
|
132 | # write |
|
|
133 | print "\tif (newval)\n", |
|
|
134 | "\t switch ($ix)\n", |
|
|
135 | "\t {\n", |
|
|
136 | (map "\t case $_: sv_to (newval, $self$member[$_][1]); break;\n", |
|
|
137 | grep $member[$_][0] eq "W", |
|
|
138 | 0 .. $#member), |
|
|
139 | "\t default: croak (\"scalar_member is read-only\");\n", |
|
|
140 | "\t };\n"; |
|
|
141 | |
|
|
142 | print "\tOUTPUT: RETVAL\n\n"; |
|
|
143 | } |
|
|
144 | } |
|
|
145 | |
|
|
146 | if (@array_member) { |
|
|
147 | print "SV *$array_member[0][1] ($class *self, int idx, SV *newval = 0)\n"; |
| 57 | print "\tPROTOTYPE: \$;\$\n"; |
148 | print "\tPROTOTYPE: \$;\$\n"; |
| 58 | |
149 | |
| 59 | if (@scalar_member > 1) { |
150 | if (@array_member > 1) { |
| 60 | print "\tALIAS:\n"; |
151 | print "\tALIAS:\n"; |
| 61 | for (1 .. $#scalar_member) { |
152 | for (1 .. $#array_member) { |
| 62 | print "\t\t$scalar_member[$_][1]\t= $_\n"; |
153 | print "\t\t" . (c2perl $array_member[$_][1]) . "\t= $_\n"; |
| 63 | } |
154 | } |
| 64 | } |
155 | } |
| 65 | |
156 | |
| 66 | print "\tCODE:\n"; |
157 | print "\tCODE:\n"; |
|
|
158 | |
|
|
159 | print "\tif (idx < 0) croak (\"negative array index\");\n"; |
|
|
160 | |
|
|
161 | my $ix = @array_member == 1 ? 0 : "ix"; |
|
|
162 | |
|
|
163 | # range |
|
|
164 | print "\t switch ($ix)\n", |
|
|
165 | "\t {\n", |
|
|
166 | (map "\t case $_: if (idx >= $array_member[$_][3]) croak (\"array index out of bounds\"); break;\n", |
|
|
167 | 0 .. $#array_member), |
|
|
168 | "\t };\n"; |
| 67 | |
169 | |
| 68 | # read |
170 | # read |
| 69 | print "\tif (GIMME_V == G_VOID)\n", |
171 | print "\tif (GIMME_V == G_VOID)\n", |
| 70 | "\t RETVAL = &PL_sv_undef;\n", |
172 | "\t RETVAL = &PL_sv_undef;\n", |
| 71 | "\telse\n", |
173 | "\telse\n", |
| 72 | "\t switch (ix)\n", |
174 | "\t switch ($ix)\n", |
| 73 | "\t {\n", |
|
|
| 74 | (map "\t case $_: RETVAL = to_sv (self->$scalar_member[$_][1]); break;\n", |
|
|
| 75 | 0 .. $#scalar_member), |
|
|
| 76 | "\t default: croak (\"scalar_member is write-only\");\n", |
|
|
| 77 | "\t };\n"; |
|
|
| 78 | |
|
|
| 79 | # write |
|
|
| 80 | print "\tif (newval)\n", |
|
|
| 81 | "\t switch (ix)\n", |
|
|
| 82 | "\t {\n", |
|
|
| 83 | (map "\t case $_: sv_to (newval, self->$scalar_member[$_][1]); break;\n", |
|
|
| 84 | grep $scalar_member[$_][0] eq "W", |
|
|
| 85 | 0 .. $#scalar_member), |
|
|
| 86 | "\t default: croak (\"scalar_member is read-only\");\n", |
|
|
| 87 | "\t };\n"; |
|
|
| 88 | |
|
|
| 89 | print "\tOUTPUT: RETVAL\n\n"; |
|
|
| 90 | } |
|
|
| 91 | |
|
|
| 92 | if (@array_member) { |
|
|
| 93 | print "SV *$array_member[0][1] ($class *self, int idx, SV *newval = 0)\n"; |
|
|
| 94 | print "\tPROTOTYPE: \$;\$\n"; |
|
|
| 95 | |
|
|
| 96 | if (@array_member > 1) { |
|
|
| 97 | print "\tALIAS:\n"; |
|
|
| 98 | for (1 .. $#array_member) { |
|
|
| 99 | print "\t\t$array_member[$_][1]\t= $_\n"; |
|
|
| 100 | } |
|
|
| 101 | } |
|
|
| 102 | |
|
|
| 103 | print "\tCODE:\n"; |
|
|
| 104 | |
|
|
| 105 | print "\tif (idx < 0) croak (\"negative array index\");\n"; |
|
|
| 106 | |
|
|
| 107 | # range |
|
|
| 108 | print "\t switch (ix)\n", |
|
|
| 109 | "\t {\n", |
|
|
| 110 | (map "\t case $_: if (idx >= $array_member[$_][2]) croak (\"array index out of bounds\"); break;\n", |
|
|
| 111 | 0 .. $#array_member), |
|
|
| 112 | "\t };\n"; |
|
|
| 113 | |
|
|
| 114 | # read |
|
|
| 115 | print "\tif (GIMME_V == G_VOID)\n", |
|
|
| 116 | "\t RETVAL = &PL_sv_undef;\n", |
|
|
| 117 | "\telse\n", |
|
|
| 118 | "\t switch (ix)\n", |
|
|
| 119 | "\t {\n", |
175 | "\t {\n", |
| 120 | (map "\t case $_: RETVAL = to_sv (self->$array_member[$_][1] [idx]); break;\n", |
176 | (map "\t case $_: RETVAL = to_sv (self->$array_member[$_][1] [idx]); break;\n", |
| 121 | 0 .. $#array_member), |
177 | 0 .. $#array_member), |
| 122 | "\t default: croak (\"array_member is write-only\");\n", |
178 | "\t default: croak (\"array_member is write-only\");\n", |
| 123 | "\t };\n"; |
179 | "\t };\n"; |
| 124 | |
180 | |
| 125 | # write |
181 | # write |
| 126 | print "\tif (newval)\n", |
182 | print "\tif (newval)\n", |
| 127 | "\t switch (ix)\n", |
183 | "\t switch ($ix)\n", |
| 128 | "\t {\n", |
184 | "\t {\n", |
| 129 | (map "\t case $_: sv_to (newval, self->$array_member[$_][1] [idx]); break;\n", |
185 | (map "\t case $_: sv_to (newval, self->$array_member[$_][1] [idx]); break;\n", |
| 130 | grep $array_member[$_][0] eq "W", |
186 | grep $array_member[$_][0] eq "W", |
| 131 | 0 .. $#array_member), |
187 | 0 .. $#array_member), |
| 132 | "\t default: croak (\"array_member is read-only\");\n", |
188 | "\t default: croak (\"array_member is read-only\");\n", |
| 133 | "\t };\n"; |
189 | "\t };\n"; |
| 134 | |
190 | |
| 135 | print "\tOUTPUT: RETVAL\n\n"; |
191 | print "\tOUTPUT: RETVAL\n\n"; |
| 136 | } |
192 | } |
| 137 | |
193 | |
|
|
194 | my $json = JSON::XS->new->utf8->encode ({ |
|
|
195 | class => $class, |
|
|
196 | methods => { map +($_->[1], [$_->[0], $_->[2]]), @method_member }, |
|
|
197 | scalars => { map +($_->[1], [$_->[0] ]), @scalar_member }, |
|
|
198 | arrays => { map +($_->[1], [$_->[0], $_->[2]]), @array_member }, |
|
|
199 | }); |
|
|
200 | |
|
|
201 | $json = join "\n", map { |
|
|
202 | my $part = $_; |
|
|
203 | $part =~ s/(["\\])/\\$1/g; |
|
|
204 | "\"$part\"" |
|
|
205 | } unpack "(a80)*", $json; |
|
|
206 | |
|
|
207 | print "BOOT:\n", |
|
|
208 | "\tav_push (av_reflect, newSVpv ($json, 0));\n\n"; |
|
|
209 | |
