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.7 by root, Mon Mar 5 19:54:49 2007 UTC vs.
Revision 1.11 by root, Sun Oct 11 00:24:35 2009 UTC

1#! perl 1#! perl
2 2
3# used to automatically create accessors/mutators and method interfaces 3# used to automatically create accessors/mutators and method interfaces
4# to C++ classes for Perl. 4# to C++ classes for Perl.
5# also write data structures as JSON object, for reflection
6
7use JSON::XS;
5 8
6my $class = shift; 9my $class = shift;
7my $curclass = ""; 10my $curclass = "";
8my (@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}
9 21
10for my $file (@ARGV) { 22for my $file (@ARGV) {
11 open my $fh, "<:utf8", $file 23 open my $fh, "<:utf8", $file
12 or die "$file: $!"; 24 or die "$file: $!";
13 25
… …
59 print "\tPROTOTYPE: \$;\$\n"; 71 print "\tPROTOTYPE: \$;\$\n";
60 72
61 if (@scalar_member > 1) { 73 if (@scalar_member > 1) {
62 print "\tALIAS:\n"; 74 print "\tALIAS:\n";
63 for (1 .. $#scalar_member) { 75 for (1 .. $#scalar_member) {
64 print "\t\t$scalar_member[$_][1]\t= $_\n"; 76 print "\t\t" . (c2perl $scalar_member[$_][1]) . "\t= $_\n";
65 } 77 }
66 } 78 }
67 79
68 print "\tCODE:\n"; 80 print "\tCODE:\n";
69 81
82 my $ix = @scalar_member == 1 ? 0 : "ix";
83
70# read 84# read
71 print "\tif (GIMME_V == G_VOID)\n", 85 print "\tif (GIMME_V == G_VOID)\n",
72 "\t RETVAL = &PL_sv_undef;\n", 86 "\t RETVAL = &PL_sv_undef;\n",
73 "\telse\n", 87 "\telse\n",
74 "\t switch (ix)\n", 88 "\t switch ($ix)\n",
75 "\t {\n", 89 "\t {\n",
76 (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",
77 0 .. $#scalar_member), 91 0 .. $#scalar_member),
78 "\t default: croak (\"scalar_member is write-only\");\n", 92 "\t default: croak (\"scalar_member is write-only\");\n",
79 "\t };\n"; 93 "\t };\n";
80 94
81# write 95# write
82 print "\tif (newval)\n", 96 print "\tif (newval)\n",
83 "\t switch (ix)\n", 97 "\t switch ($ix)\n",
84 "\t {\n", 98 "\t {\n",
85 (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",
86 grep $scalar_member[$_][0] eq "W", 100 grep $scalar_member[$_][0] eq "W",
87 0 .. $#scalar_member), 101 0 .. $#scalar_member),
88 "\t default: croak (\"scalar_member is read-only\");\n", 102 "\t default: croak (\"scalar_member is read-only\");\n",
… …
96 print "\tPROTOTYPE: \$;\$\n"; 110 print "\tPROTOTYPE: \$;\$\n";
97 111
98 if (@array_member > 1) { 112 if (@array_member > 1) {
99 print "\tALIAS:\n"; 113 print "\tALIAS:\n";
100 for (1 .. $#array_member) { 114 for (1 .. $#array_member) {
101 print "\t\t$array_member[$_][1]\t= $_\n"; 115 print "\t\t" . (c2perl $array_member[$_][1]) . "\t= $_\n";
102 } 116 }
103 } 117 }
104 118
105 print "\tCODE:\n"; 119 print "\tCODE:\n";
106 120
107 print "\tif (idx < 0) croak (\"negative array index\");\n"; 121 print "\tif (idx < 0) croak (\"negative array index\");\n";
108 122
123 my $ix = @array_member == 1 ? 0 : "ix";
124
109# range 125# range
110 print "\t switch (ix)\n", 126 print "\t switch ($ix)\n",
111 "\t {\n", 127 "\t {\n",
112 (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",
113 0 .. $#array_member), 129 0 .. $#array_member),
114 "\t };\n"; 130 "\t };\n";
115 131
116# read 132# read
117 print "\tif (GIMME_V == G_VOID)\n", 133 print "\tif (GIMME_V == G_VOID)\n",
118 "\t RETVAL = &PL_sv_undef;\n", 134 "\t RETVAL = &PL_sv_undef;\n",
119 "\telse\n", 135 "\telse\n",
120 "\t switch (ix)\n", 136 "\t switch ($ix)\n",
121 "\t {\n", 137 "\t {\n",
122 (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",
123 0 .. $#array_member), 139 0 .. $#array_member),
124 "\t default: croak (\"array_member is write-only\");\n", 140 "\t default: croak (\"array_member is write-only\");\n",
125 "\t };\n"; 141 "\t };\n";
126 142
127# write 143# write
128 print "\tif (newval)\n", 144 print "\tif (newval)\n",
129 "\t switch (ix)\n", 145 "\t switch ($ix)\n",
130 "\t {\n", 146 "\t {\n",
131 (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",
132 grep $array_member[$_][0] eq "W", 148 grep $array_member[$_][0] eq "W",
133 0 .. $#array_member), 149 0 .. $#array_member),
134 "\t default: croak (\"array_member is read-only\");\n", 150 "\t default: croak (\"array_member is read-only\");\n",
135 "\t };\n"; 151 "\t };\n";
136 152
137 print "\tOUTPUT: RETVAL\n\n"; 153 print "\tOUTPUT: RETVAL\n\n";
138} 154}
139 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