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.4 by root, Mon Dec 25 11:25:49 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 /
28 if ($curclass eq $class) {
14 while (/ACC\s*\(R([WO])\s*,\s*([^)\]]+)(?:\[(\S+)\])?\)/g) { 29 while (/ACC\s*\(R([WO])\s*,\s*([^)\]]+)(?:\[(\S+)\])?\)/g) {
15 next unless $curclass eq $class;
16
17 if ($3) { 30 if ($3) {
18 push @array_member, [$1, $2, $3]; 31 push @array_member, [$1, $2, $3];
19 } else { 32 } else {
20 push @scalar_member, [$1, $2]; 33 push @scalar_member, [$1, $2];
34 }
35 }
36 if (/MTH \s+ ([^(]*?) \s* ([A-Za-z_0-9]+) \s* \(([^)]*)\)/x) {
37 push @method_member, [$1, $2, $3];
21 } 38 }
22 } 39 }
23 while (/INTERFACE_CLASS\s*\((\S+)\)/g) { 40 while (/INTERFACE_CLASS\s*\((\S+)\)/g) {
24 $curclass = $1; 41 $curclass = $1;
25 } 42 }
26 } 43 }
44}
45
46for (@method_member) {
47 my ($rettype, $name, $params) = @$_;
48
49 if ($rettype =~ s/static\s+//) {
50 my $args = join ", ", $params =~ m/.*?([a-zA-Z_0-9]+)(?:,\s*|$)/g;
51 if ($rettype ne "void") {
52 print "$rettype\n$name ($params)\n",
53 "\tCODE:\n",
54 "\tRETVAL = $class\::$name ($args);\n",
55 "\tOUTPUT:\n",
56 "\tRETVAL\n";
57 } else {
58 print "$rettype\n$name ($params)\n",
59 "\tCODE:\n",
60 "\t$class\::$name ($args);\n",
61 }
62 } else {
63 print "$rettype\n$class\::$name ($params)\n";
64 }
65
66 print "\n";
27} 67}
28 68
29if (@scalar_member) { 69if (@scalar_member) {
30 print "SV *$scalar_member[0][1] ($class *self, SV *newval = 0)\n"; 70 print "SV *$scalar_member[0][1] ($class *self, SV *newval = 0)\n";
31 print "\tPROTOTYPE: \$;\$\n"; 71 print "\tPROTOTYPE: \$;\$\n";
32 72
33 if (@scalar_member > 1) { 73 if (@scalar_member > 1) {
34 print "\tALIAS:\n"; 74 print "\tALIAS:\n";
35 for (1 .. $#scalar_member) { 75 for (1 .. $#scalar_member) {
36 print "\t\t$scalar_member[$_][1]\t= $_\n"; 76 print "\t\t" . (c2perl $scalar_member[$_][1]) . "\t= $_\n";
37 } 77 }
38 } 78 }
39 79
40 print "\tCODE:\n"; 80 print "\tCODE:\n";
41 81
82 my $ix = @scalar_member == 1 ? 0 : "ix";
83
42# read 84# read
43 print "\tif (GIMME_V == G_VOID)\n", 85 print "\tif (GIMME_V == G_VOID)\n",
44 "\t RETVAL = &PL_sv_undef;\n", 86 "\t RETVAL = &PL_sv_undef;\n",
45 "\telse\n", 87 "\telse\n",
46 "\t switch (ix)\n", 88 "\t switch ($ix)\n",
47 "\t {\n", 89 "\t {\n",
48 (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",
49 0 .. $#scalar_member), 91 0 .. $#scalar_member),
50 "\t default: croak (\"scalar_member is write-only\");\n", 92 "\t default: croak (\"scalar_member is write-only\");\n",
51 "\t };\n"; 93 "\t };\n";
52 94
53# write 95# write
54 print "\tif (newval)\n", 96 print "\tif (newval)\n",
55 "\t switch (ix)\n", 97 "\t switch ($ix)\n",
56 "\t {\n", 98 "\t {\n",
57 (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",
58 grep $scalar_member[$_][0] eq "W", 100 grep $scalar_member[$_][0] eq "W",
59 0 .. $#scalar_member), 101 0 .. $#scalar_member),
60 "\t default: croak (\"scalar_member is read-only\");\n", 102 "\t default: croak (\"scalar_member is read-only\");\n",
… …
68 print "\tPROTOTYPE: \$;\$\n"; 110 print "\tPROTOTYPE: \$;\$\n";
69 111
70 if (@array_member > 1) { 112 if (@array_member > 1) {
71 print "\tALIAS:\n"; 113 print "\tALIAS:\n";
72 for (1 .. $#array_member) { 114 for (1 .. $#array_member) {
73 print "\t\t$array_member[$_][1]\t= $_\n"; 115 print "\t\t" . (c2perl $array_member[$_][1]) . "\t= $_\n";
74 } 116 }
75 } 117 }
76 118
77 print "\tCODE:\n"; 119 print "\tCODE:\n";
78 120
79 print "\tif (idx < 0) croak (\"negative array index\");\n"; 121 print "\tif (idx < 0) croak (\"negative array index\");\n";
80 122
123 my $ix = @array_member == 1 ? 0 : "ix";
124
81# range 125# range
82 print "\t switch (ix)\n", 126 print "\t switch ($ix)\n",
83 "\t {\n", 127 "\t {\n",
84 (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",
85 0 .. $#array_member), 129 0 .. $#array_member),
86 "\t };\n"; 130 "\t };\n";
87 131
88# read 132# read
89 print "\tif (GIMME_V == G_VOID)\n", 133 print "\tif (GIMME_V == G_VOID)\n",
90 "\t RETVAL = &PL_sv_undef;\n", 134 "\t RETVAL = &PL_sv_undef;\n",
91 "\telse\n", 135 "\telse\n",
92 "\t switch (ix)\n", 136 "\t switch ($ix)\n",
93 "\t {\n", 137 "\t {\n",
94 (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",
95 0 .. $#array_member), 139 0 .. $#array_member),
96 "\t default: croak (\"array_member is write-only\");\n", 140 "\t default: croak (\"array_member is write-only\");\n",
97 "\t };\n"; 141 "\t };\n";
98 142
99# write 143# write
100 print "\tif (newval)\n", 144 print "\tif (newval)\n",
101 "\t switch (ix)\n", 145 "\t switch ($ix)\n",
102 "\t {\n", 146 "\t {\n",
103 (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",
104 grep $array_member[$_][0] eq "W", 148 grep $array_member[$_][0] eq "W",
105 0 .. $#array_member), 149 0 .. $#array_member),
106 "\t default: croak (\"array_member is read-only\");\n", 150 "\t default: croak (\"array_member is read-only\");\n",
107 "\t };\n"; 151 "\t };\n";
108 152
109 print "\tOUTPUT: RETVAL\n\n"; 153 print "\tOUTPUT: RETVAL\n\n";
110} 154}
111 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