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.3 by root, Sat Dec 23 15:49:40 2006 UTC vs.
Revision 1.11 by root, Sun Oct 11 00:24:35 2009 UTC

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