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.11 by root, Sun Oct 11 00:24:35 2009 UTC

1#! perl 1#! perl
2 2
3# actually geninterface 3# used to automatically create accessors/mutators and method interfaces
4# to C++ classes for Perl.
5# also write data structures as JSON object, for reflection
6
7use JSON::XS;
4 8
5my $class = shift; 9my $class = shift;
6my $curclass = ""; 10my $curclass = "";
7my (@scalar_member, @array_member); 11my (@scalar_member, @array_member);
12
13# convert c member name to perl
14sub c2perl($) {
15 local $_ = shift;
16
17 s/^([^.]+)\.\1_/$1\_/g; # tcpi.tcpi_xxx => tcpi_xxx
18
19 $_
20}
8 21
9for my $file (@ARGV) { 22for my $file (@ARGV) {
10 open my $fh, "<:utf8", $file 23 open my $fh, "<:utf8", $file
11 or die "$file: $!"; 24 or die "$file: $!";
12 25
13 while (<$fh>) { 26 while (<$fh>) {
27 next if /^\s*\//; # skip lines starting with /
14 if ($curclass eq $class) { 28 if ($curclass eq $class) {
15 while (/ACC\s*\(R([WO])\s*,\s*([^)\]]+)(?:\[(\S+)\])?\)/g) { 29 while (/ACC\s*\(R([WO])\s*,\s*([^)\]]+)(?:\[(\S+)\])?\)/g) {
16 if ($3) { 30 if ($3) {
17 push @array_member, [$1, $2, $3]; 31 push @array_member, [$1, $2, $3];
18 } else { 32 } else {
… …
57 print "\tPROTOTYPE: \$;\$\n"; 71 print "\tPROTOTYPE: \$;\$\n";
58 72
59 if (@scalar_member > 1) { 73 if (@scalar_member > 1) {
60 print "\tALIAS:\n"; 74 print "\tALIAS:\n";
61 for (1 .. $#scalar_member) { 75 for (1 .. $#scalar_member) {
62 print "\t\t$scalar_member[$_][1]\t= $_\n"; 76 print "\t\t" . (c2perl $scalar_member[$_][1]) . "\t= $_\n";
63 } 77 }
64 } 78 }
65 79
66 print "\tCODE:\n"; 80 print "\tCODE:\n";
67 81
82 my $ix = @scalar_member == 1 ? 0 : "ix";
83
68# read 84# read
69 print "\tif (GIMME_V == G_VOID)\n", 85 print "\tif (GIMME_V == G_VOID)\n",
70 "\t RETVAL = &PL_sv_undef;\n", 86 "\t RETVAL = &PL_sv_undef;\n",
71 "\telse\n", 87 "\telse\n",
72 "\t switch (ix)\n", 88 "\t switch ($ix)\n",
73 "\t {\n", 89 "\t {\n",
74 (map "\t case $_: RETVAL = to_sv (self->$scalar_member[$_][1]); break;\n", 90 (map "\t case $_: RETVAL = to_sv (self->$scalar_member[$_][1]); break;\n",
75 0 .. $#scalar_member), 91 0 .. $#scalar_member),
76 "\t default: croak (\"scalar_member is write-only\");\n", 92 "\t default: croak (\"scalar_member is write-only\");\n",
77 "\t };\n"; 93 "\t };\n";
78 94
79# write 95# write
80 print "\tif (newval)\n", 96 print "\tif (newval)\n",
81 "\t switch (ix)\n", 97 "\t switch ($ix)\n",
82 "\t {\n", 98 "\t {\n",
83 (map "\t case $_: sv_to (newval, self->$scalar_member[$_][1]); break;\n", 99 (map "\t case $_: sv_to (newval, self->$scalar_member[$_][1]); break;\n",
84 grep $scalar_member[$_][0] eq "W", 100 grep $scalar_member[$_][0] eq "W",
85 0 .. $#scalar_member), 101 0 .. $#scalar_member),
86 "\t default: croak (\"scalar_member is read-only\");\n", 102 "\t default: croak (\"scalar_member is read-only\");\n",
… …
94 print "\tPROTOTYPE: \$;\$\n"; 110 print "\tPROTOTYPE: \$;\$\n";
95 111
96 if (@array_member > 1) { 112 if (@array_member > 1) {
97 print "\tALIAS:\n"; 113 print "\tALIAS:\n";
98 for (1 .. $#array_member) { 114 for (1 .. $#array_member) {
99 print "\t\t$array_member[$_][1]\t= $_\n"; 115 print "\t\t" . (c2perl $array_member[$_][1]) . "\t= $_\n";
100 } 116 }
101 } 117 }
102 118
103 print "\tCODE:\n"; 119 print "\tCODE:\n";
104 120
105 print "\tif (idx < 0) croak (\"negative array index\");\n"; 121 print "\tif (idx < 0) croak (\"negative array index\");\n";
106 122
123 my $ix = @array_member == 1 ? 0 : "ix";
124
107# range 125# range
108 print "\t switch (ix)\n", 126 print "\t switch ($ix)\n",
109 "\t {\n", 127 "\t {\n",
110 (map "\t case $_: if (idx >= $array_member[$_][2]) croak (\"array index out of bounds\"); break;\n", 128 (map "\t case $_: if (idx >= $array_member[$_][2]) croak (\"array index out of bounds\"); break;\n",
111 0 .. $#array_member), 129 0 .. $#array_member),
112 "\t };\n"; 130 "\t };\n";
113 131
114# read 132# read
115 print "\tif (GIMME_V == G_VOID)\n", 133 print "\tif (GIMME_V == G_VOID)\n",
116 "\t RETVAL = &PL_sv_undef;\n", 134 "\t RETVAL = &PL_sv_undef;\n",
117 "\telse\n", 135 "\telse\n",
118 "\t switch (ix)\n", 136 "\t switch ($ix)\n",
119 "\t {\n", 137 "\t {\n",
120 (map "\t case $_: RETVAL = to_sv (self->$array_member[$_][1] [idx]); break;\n", 138 (map "\t case $_: RETVAL = to_sv (self->$array_member[$_][1] [idx]); break;\n",
121 0 .. $#array_member), 139 0 .. $#array_member),
122 "\t default: croak (\"array_member is write-only\");\n", 140 "\t default: croak (\"array_member is write-only\");\n",
123 "\t };\n"; 141 "\t };\n";
124 142
125# write 143# write
126 print "\tif (newval)\n", 144 print "\tif (newval)\n",
127 "\t switch (ix)\n", 145 "\t switch ($ix)\n",
128 "\t {\n", 146 "\t {\n",
129 (map "\t case $_: sv_to (newval, self->$array_member[$_][1] [idx]); break;\n", 147 (map "\t case $_: sv_to (newval, self->$array_member[$_][1] [idx]); break;\n",
130 grep $array_member[$_][0] eq "W", 148 grep $array_member[$_][0] eq "W",
131 0 .. $#array_member), 149 0 .. $#array_member),
132 "\t default: croak (\"array_member is read-only\");\n", 150 "\t default: croak (\"array_member is read-only\");\n",
133 "\t };\n"; 151 "\t };\n";
134 152
135 print "\tOUTPUT: RETVAL\n\n"; 153 print "\tOUTPUT: RETVAL\n\n";
136} 154}
137 155
156my $json = JSON::XS->new->utf8->encode ({
157 class => $class,
158 methods => { map +($_->[1], [$_->[0], $_->[2]]), @method_member },
159 scalars => { map +($_->[1], [$_->[0] ]), @scalar_member },
160 arrays => { map +($_->[1], [$_->[0], $_->[2]]), @array_member },
161});
162
163$json = join "\n", map {
164 my $part = $_;
165 $part =~ s/(["\\])/\\$1/g;
166 "\"$part\""
167 } unpack "(a80)*", $json;
168
169print "BOOT:\n",
170 "\tav_push (av_reflect, newSVpv ($json, 0));\n\n";
171

Diff Legend

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