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.11 by root, Sun Oct 11 00:24:35 2009 UTC vs.
Revision 1.13 by root, Mon Apr 12 05:22:30 2010 UTC

1#! perl 1#! perl
2
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#
2 24
3# used to automatically create accessors/mutators and method interfaces 25# used to automatically create accessors/mutators and method interfaces
4# to C++ classes for Perl. 26# to C++ classes for Perl.
5# also write data structures as JSON object, for reflection 27# also write data structures as JSON object, for reflection
6 28
… …
25 47
26 while (<$fh>) { 48 while (<$fh>) {
27 next if /^\s*\//; # skip lines starting with / 49 next if /^\s*\//; # skip lines starting with /
28 if ($curclass eq $class) { 50 if ($curclass eq $class) {
29 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/;
30 if ($3) { 54 if ($count) {
55 die "static array members not yet supported by genacc" if $static;
31 push @array_member, [$1, $2, $3]; 56 push @array_member, [$access, $name, $static, $count];
32 } else { 57 } else {
33 push @scalar_member, [$1, $2]; 58 push @scalar_member, [$access, $name, $static];
34 } 59 }
35 } 60 }
36 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);
37 push @method_member, [$1, $2, $3]; 63 push @method_member, [$retval, $name, $args];
38 } 64 }
39 } 65 }
40 while (/INTERFACE_CLASS\s*\((\S+)\)/g) { 66 while (/INTERFACE_CLASS\s*\((\S+)\)/g) {
41 $curclass = $1; 67 $curclass = $1;
42 } 68 }
… …
64 } 90 }
65 91
66 print "\n"; 92 print "\n";
67} 93}
68 94
69if (@scalar_member) { 95for 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->";
70 print "SV *$scalar_member[0][1] ($class *self, SV *newval = 0)\n"; 106 print "SV *$member[0][1] ($class *self, SV *newval = 0)\n",
71 print "\tPROTOTYPE: \$;\$\n"; 107 "\tPROTOTYPE: \$;\$\n";
108 }
72 109
73 if (@scalar_member > 1) { 110 if (@member > 1) {
74 print "\tALIAS:\n"; 111 print "\tALIAS:\n";
75 for (1 .. $#scalar_member) { 112 for (1 .. $#member) {
76 print "\t\t" . (c2perl $scalar_member[$_][1]) . "\t= $_\n"; 113 print "\t\t" . (c2perl $member[$_][1]) . "\t= $_\n";
77 } 114 }
78 } 115 }
79 116
80 print "\tCODE:\n"; 117 print "\tCODE:\n";
81 118
82 my $ix = @scalar_member == 1 ? 0 : "ix"; 119 my $ix = @member == 1 ? 0 : "ix";
83 120
84# read 121# read
85 print "\tif (GIMME_V == G_VOID)\n", 122 print "\tif (GIMME_V == G_VOID)\n",
86 "\t RETVAL = &PL_sv_undef;\n", 123 "\t RETVAL = &PL_sv_undef;\n",
87 "\telse\n", 124 "\telse\n",
88 "\t switch ($ix)\n", 125 "\t switch ($ix)\n",
89 "\t {\n", 126 "\t {\n",
90 (map "\t case $_: RETVAL = to_sv (self->$scalar_member[$_][1]); break;\n", 127 (map "\t case $_: RETVAL = to_sv ($self$member[$_][1]); break;\n",
91 0 .. $#scalar_member), 128 0 .. $#member),
92 "\t default: croak (\"scalar_member is write-only\");\n", 129 "\t default: croak (\"scalar_member is write-only\");\n",
93 "\t };\n"; 130 "\t };\n";
94 131
95# write 132# write
96 print "\tif (newval)\n", 133 print "\tif (newval)\n",
97 "\t switch ($ix)\n", 134 "\t switch ($ix)\n",
98 "\t {\n", 135 "\t {\n",
99 (map "\t case $_: sv_to (newval, self->$scalar_member[$_][1]); break;\n", 136 (map "\t case $_: sv_to (newval, $self$member[$_][1]); break;\n",
100 grep $scalar_member[$_][0] eq "W", 137 grep $member[$_][0] eq "W",
101 0 .. $#scalar_member), 138 0 .. $#member),
102 "\t default: croak (\"scalar_member is read-only\");\n", 139 "\t default: croak (\"scalar_member is read-only\");\n",
103 "\t };\n"; 140 "\t };\n";
104 141
105 print "\tOUTPUT: RETVAL\n\n"; 142 print "\tOUTPUT: RETVAL\n\n";
143 }
106} 144}
107 145
108if (@array_member) { 146if (@array_member) {
109 print "SV *$array_member[0][1] ($class *self, int idx, SV *newval = 0)\n"; 147 print "SV *$array_member[0][1] ($class *self, int idx, SV *newval = 0)\n";
110 print "\tPROTOTYPE: \$;\$\n"; 148 print "\tPROTOTYPE: \$;\$\n";
… …
123 my $ix = @array_member == 1 ? 0 : "ix"; 161 my $ix = @array_member == 1 ? 0 : "ix";
124 162
125# range 163# range
126 print "\t switch ($ix)\n", 164 print "\t switch ($ix)\n",
127 "\t {\n", 165 "\t {\n",
128 (map "\t case $_: if (idx >= $array_member[$_][2]) croak (\"array index out of bounds\"); break;\n", 166 (map "\t case $_: if (idx >= $array_member[$_][3]) croak (\"array index out of bounds\"); break;\n",
129 0 .. $#array_member), 167 0 .. $#array_member),
130 "\t };\n"; 168 "\t };\n";
131 169
132# read 170# read
133 print "\tif (GIMME_V == G_VOID)\n", 171 print "\tif (GIMME_V == G_VOID)\n",

Diff Legend

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