1 |
#! perl |
2 |
|
3 |
my $class = shift; |
4 |
my $curclass = ""; |
5 |
my @member; |
6 |
|
7 |
for my $file (@ARGV) { |
8 |
open my $fh, "<:utf8", $file |
9 |
or die "$file: $!"; |
10 |
|
11 |
while (<$fh>) { |
12 |
while (/ACC\s*\(R([WO])\s*,\s*(\S+)\)/g) { |
13 |
next unless $curclass eq $class; |
14 |
|
15 |
push @member, [$1, $2]; |
16 |
} |
17 |
while (/ACC_CLASS\s*\((\S+)\)/g) { |
18 |
$curclass = $1; |
19 |
} |
20 |
} |
21 |
} |
22 |
|
23 |
exit unless @member; |
24 |
|
25 |
print "SV *$member[0][1] ($class *self, SV *newval = 0)\n"; |
26 |
print "\tPROTOTYPE: \$;\$\n"; |
27 |
|
28 |
if (@member > 1) { |
29 |
print "\tALIAS:\n"; |
30 |
for (1 .. $#member) { |
31 |
print "\t\t$member[$_][1]\t= $_\n"; |
32 |
} |
33 |
} |
34 |
|
35 |
print "\tCODE:\n"; |
36 |
|
37 |
# read |
38 |
print "\tif (GIMME_V == G_VOID)\n", |
39 |
"\t RETVAL = &PL_sv_undef;\n", |
40 |
"\telse\n", |
41 |
"\t switch (ix)\n", |
42 |
"\t {\n", |
43 |
(map "\t case $_: RETVAL = to_sv (self->$member[$_][1]); break;\n", |
44 |
0 .. $#member), |
45 |
"\t default: croak (\"member is write-only\");\n", |
46 |
"\t };\n"; |
47 |
|
48 |
# write |
49 |
print "\tif (newval)\n", |
50 |
"\t switch (ix)\n", |
51 |
"\t {\n", |
52 |
(map "\t case $_: sv_to (newval, self->$member[$_][1]); break;\n", |
53 |
grep $member[$_][0] eq "W", |
54 |
0 .. $#member), |
55 |
"\t default: croak (\"member is read-only\");\n", |
56 |
"\t };\n"; |
57 |
|
58 |
print "\tOUTPUT: RETVAL\n"; |
59 |
|