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.6 by root, Sun Dec 31 10:28:36 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
… …
58 print "\tPROTOTYPE: \$;\$\n"; 71 print "\tPROTOTYPE: \$;\$\n";
59 72
60 if (@scalar_member > 1) { 73 if (@scalar_member > 1) {
61 print "\tALIAS:\n"; 74 print "\tALIAS:\n";
62 for (1 .. $#scalar_member) { 75 for (1 .. $#scalar_member) {
63 print "\t\t$scalar_member[$_][1]\t= $_\n"; 76 print "\t\t" . (c2perl $scalar_member[$_][1]) . "\t= $_\n";
64 } 77 }
65 } 78 }
66 79
67 print "\tCODE:\n"; 80 print "\tCODE:\n";
68 81
82 my $ix = @scalar_member == 1 ? 0 : "ix";
83
69# read 84# read
70 print "\tif (GIMME_V == G_VOID)\n", 85 print "\tif (GIMME_V == G_VOID)\n",
71 "\t RETVAL = &PL_sv_undef;\n", 86 "\t RETVAL = &PL_sv_undef;\n",
72 "\telse\n", 87 "\telse\n",
73 "\t switch (ix)\n", 88 "\t switch ($ix)\n",
74 "\t {\n", 89 "\t {\n",
75 (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",
76 0 .. $#scalar_member), 91 0 .. $#scalar_member),
77 "\t default: croak (\"scalar_member is write-only\");\n", 92 "\t default: croak (\"scalar_member is write-only\");\n",
78 "\t };\n"; 93 "\t };\n";
79 94
80# write 95# write
81 print "\tif (newval)\n", 96 print "\tif (newval)\n",
82 "\t switch (ix)\n", 97 "\t switch ($ix)\n",
83 "\t {\n", 98 "\t {\n",
84 (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",
85 grep $scalar_member[$_][0] eq "W", 100 grep $scalar_member[$_][0] eq "W",
86 0 .. $#scalar_member), 101 0 .. $#scalar_member),
87 "\t default: croak (\"scalar_member is read-only\");\n", 102 "\t default: croak (\"scalar_member is read-only\");\n",
… …
95 print "\tPROTOTYPE: \$;\$\n"; 110 print "\tPROTOTYPE: \$;\$\n";
96 111
97 if (@array_member > 1) { 112 if (@array_member > 1) {
98 print "\tALIAS:\n"; 113 print "\tALIAS:\n";
99 for (1 .. $#array_member) { 114 for (1 .. $#array_member) {
100 print "\t\t$array_member[$_][1]\t= $_\n"; 115 print "\t\t" . (c2perl $array_member[$_][1]) . "\t= $_\n";
101 } 116 }
102 } 117 }
103 118
104 print "\tCODE:\n"; 119 print "\tCODE:\n";
105 120
106 print "\tif (idx < 0) croak (\"negative array index\");\n"; 121 print "\tif (idx < 0) croak (\"negative array index\");\n";
107 122
123 my $ix = @array_member == 1 ? 0 : "ix";
124
108# range 125# range
109 print "\t switch (ix)\n", 126 print "\t switch ($ix)\n",
110 "\t {\n", 127 "\t {\n",
111 (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",
112 0 .. $#array_member), 129 0 .. $#array_member),
113 "\t };\n"; 130 "\t };\n";
114 131
115# read 132# read
116 print "\tif (GIMME_V == G_VOID)\n", 133 print "\tif (GIMME_V == G_VOID)\n",
117 "\t RETVAL = &PL_sv_undef;\n", 134 "\t RETVAL = &PL_sv_undef;\n",
118 "\telse\n", 135 "\telse\n",
119 "\t switch (ix)\n", 136 "\t switch ($ix)\n",
120 "\t {\n", 137 "\t {\n",
121 (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",
122 0 .. $#array_member), 139 0 .. $#array_member),
123 "\t default: croak (\"array_member is write-only\");\n", 140 "\t default: croak (\"array_member is write-only\");\n",
124 "\t };\n"; 141 "\t };\n";
125 142
126# write 143# write
127 print "\tif (newval)\n", 144 print "\tif (newval)\n",
128 "\t switch (ix)\n", 145 "\t switch ($ix)\n",
129 "\t {\n", 146 "\t {\n",
130 (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",
131 grep $array_member[$_][0] eq "W", 148 grep $array_member[$_][0] eq "W",
132 0 .. $#array_member), 149 0 .. $#array_member),
133 "\t default: croak (\"array_member is read-only\");\n", 150 "\t default: croak (\"array_member is read-only\");\n",
134 "\t };\n"; 151 "\t };\n";
135 152
136 print "\tOUTPUT: RETVAL\n\n"; 153 print "\tOUTPUT: RETVAL\n\n";
137} 154}
138 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