ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/server/genacc
(Generate patch)

Comparing deliantra/server/server/genacc (file contents):
Revision 1.5 by root, Sat Dec 30 10:16:11 2006 UTC vs.
Revision 1.12 by root, Tue Nov 3 23:44:21 2009 UTC

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
29use JSON::XS;
4 30
5my $class = shift; 31my $class = shift;
6my $curclass = ""; 32my $curclass = "";
7my (@scalar_member, @array_member); 33my (@scalar_member, @array_member);
34
35# convert c member name to perl
36sub c2perl($) {
37 local $_ = shift;
38
39 s/^([^.]+)\.\1_/$1\_/g; # tcpi.tcpi_xxx => tcpi_xxx
40
41 $_
42}
8 43
9for my $file (@ARGV) { 44for 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) {
16 if ($3) { 52 if ($3) {
17 push @array_member, [$1, $2, $3]; 53 push @array_member, [$1, $2, $3];
18 } else { 54 } else {
… …
57 print "\tPROTOTYPE: \$;\$\n"; 93 print "\tPROTOTYPE: \$;\$\n";
58 94
59 if (@scalar_member > 1) { 95 if (@scalar_member > 1) {
60 print "\tALIAS:\n"; 96 print "\tALIAS:\n";
61 for (1 .. $#scalar_member) { 97 for (1 .. $#scalar_member) {
62 print "\t\t$scalar_member[$_][1]\t= $_\n"; 98 print "\t\t" . (c2perl $scalar_member[$_][1]) . "\t= $_\n";
63 } 99 }
64 } 100 }
65 101
66 print "\tCODE:\n"; 102 print "\tCODE:\n";
67 103
104 my $ix = @scalar_member == 1 ? 0 : "ix";
105
68# read 106# read
69 print "\tif (GIMME_V == G_VOID)\n", 107 print "\tif (GIMME_V == G_VOID)\n",
70 "\t RETVAL = &PL_sv_undef;\n", 108 "\t RETVAL = &PL_sv_undef;\n",
71 "\telse\n", 109 "\telse\n",
72 "\t switch (ix)\n", 110 "\t switch ($ix)\n",
73 "\t {\n", 111 "\t {\n",
74 (map "\t case $_: RETVAL = to_sv (self->$scalar_member[$_][1]); break;\n", 112 (map "\t case $_: RETVAL = to_sv (self->$scalar_member[$_][1]); break;\n",
75 0 .. $#scalar_member), 113 0 .. $#scalar_member),
76 "\t default: croak (\"scalar_member is write-only\");\n", 114 "\t default: croak (\"scalar_member is write-only\");\n",
77 "\t };\n"; 115 "\t };\n";
78 116
79# write 117# write
80 print "\tif (newval)\n", 118 print "\tif (newval)\n",
81 "\t switch (ix)\n", 119 "\t switch ($ix)\n",
82 "\t {\n", 120 "\t {\n",
83 (map "\t case $_: sv_to (newval, self->$scalar_member[$_][1]); break;\n", 121 (map "\t case $_: sv_to (newval, self->$scalar_member[$_][1]); break;\n",
84 grep $scalar_member[$_][0] eq "W", 122 grep $scalar_member[$_][0] eq "W",
85 0 .. $#scalar_member), 123 0 .. $#scalar_member),
86 "\t default: croak (\"scalar_member is read-only\");\n", 124 "\t default: croak (\"scalar_member is read-only\");\n",
… …
94 print "\tPROTOTYPE: \$;\$\n"; 132 print "\tPROTOTYPE: \$;\$\n";
95 133
96 if (@array_member > 1) { 134 if (@array_member > 1) {
97 print "\tALIAS:\n"; 135 print "\tALIAS:\n";
98 for (1 .. $#array_member) { 136 for (1 .. $#array_member) {
99 print "\t\t$array_member[$_][1]\t= $_\n"; 137 print "\t\t" . (c2perl $array_member[$_][1]) . "\t= $_\n";
100 } 138 }
101 } 139 }
102 140
103 print "\tCODE:\n"; 141 print "\tCODE:\n";
104 142
105 print "\tif (idx < 0) croak (\"negative array index\");\n"; 143 print "\tif (idx < 0) croak (\"negative array index\");\n";
106 144
145 my $ix = @array_member == 1 ? 0 : "ix";
146
107# range 147# range
108 print "\t switch (ix)\n", 148 print "\t switch ($ix)\n",
109 "\t {\n", 149 "\t {\n",
110 (map "\t case $_: if (idx >= $array_member[$_][2]) croak (\"array index out of bounds\"); break;\n", 150 (map "\t case $_: if (idx >= $array_member[$_][2]) croak (\"array index out of bounds\"); break;\n",
111 0 .. $#array_member), 151 0 .. $#array_member),
112 "\t };\n"; 152 "\t };\n";
113 153
114# read 154# read
115 print "\tif (GIMME_V == G_VOID)\n", 155 print "\tif (GIMME_V == G_VOID)\n",
116 "\t RETVAL = &PL_sv_undef;\n", 156 "\t RETVAL = &PL_sv_undef;\n",
117 "\telse\n", 157 "\telse\n",
118 "\t switch (ix)\n", 158 "\t switch ($ix)\n",
119 "\t {\n", 159 "\t {\n",
120 (map "\t case $_: RETVAL = to_sv (self->$array_member[$_][1] [idx]); break;\n", 160 (map "\t case $_: RETVAL = to_sv (self->$array_member[$_][1] [idx]); break;\n",
121 0 .. $#array_member), 161 0 .. $#array_member),
122 "\t default: croak (\"array_member is write-only\");\n", 162 "\t default: croak (\"array_member is write-only\");\n",
123 "\t };\n"; 163 "\t };\n";
124 164
125# write 165# write
126 print "\tif (newval)\n", 166 print "\tif (newval)\n",
127 "\t switch (ix)\n", 167 "\t switch ($ix)\n",
128 "\t {\n", 168 "\t {\n",
129 (map "\t case $_: sv_to (newval, self->$array_member[$_][1] [idx]); break;\n", 169 (map "\t case $_: sv_to (newval, self->$array_member[$_][1] [idx]); break;\n",
130 grep $array_member[$_][0] eq "W", 170 grep $array_member[$_][0] eq "W",
131 0 .. $#array_member), 171 0 .. $#array_member),
132 "\t default: croak (\"array_member is read-only\");\n", 172 "\t default: croak (\"array_member is read-only\");\n",
133 "\t };\n"; 173 "\t };\n";
134 174
135 print "\tOUTPUT: RETVAL\n\n"; 175 print "\tOUTPUT: RETVAL\n\n";
136} 176}
137 177
178my $json = JSON::XS->new->utf8->encode ({
179 class => $class,
180 methods => { map +($_->[1], [$_->[0], $_->[2]]), @method_member },
181 scalars => { map +($_->[1], [$_->[0] ]), @scalar_member },
182 arrays => { map +($_->[1], [$_->[0], $_->[2]]), @array_member },
183});
184
185$json = join "\n", map {
186 my $part = $_;
187 $part =~ s/(["\\])/\\$1/g;
188 "\"$part\""
189 } unpack "(a80)*", $json;
190
191print "BOOT:\n",
192 "\tav_push (av_reflect, newSVpv ($json, 0));\n\n";
193

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines