1 | #! perl |
1 | #! perl |
2 | |
2 | |
3 | my $class = shift; |
3 | my $class = shift; |
4 | my $curclass = ""; |
4 | my $curclass = ""; |
5 | my @member; |
5 | my (@scalar_member, @array_member); |
6 | |
6 | |
7 | for my $file (@ARGV) { |
7 | for my $file (@ARGV) { |
8 | open my $fh, "<:utf8", $file |
8 | open my $fh, "<:utf8", $file |
9 | or die "$file: $!"; |
9 | or die "$file: $!"; |
10 | |
10 | |
11 | while (<$fh>) { |
11 | while (<$fh>) { |
12 | while (/ACC\s*\(R([WO])\s*,\s*(\S+)\)/g) { |
12 | while (/ACC\s*\(R([WO])\s*,\s*([^)\]]+)(?:\[(\S+)\])?\)/g) { |
13 | next unless $curclass eq $class; |
13 | next unless $curclass eq $class; |
14 | |
14 | |
|
|
15 | if ($3) { |
|
|
16 | push @array_member, [$1, $2, $3]; |
|
|
17 | } else { |
15 | push @member, [$1, $2]; |
18 | push @scalar_member, [$1, $2]; |
|
|
19 | } |
16 | } |
20 | } |
17 | while (/ACC_CLASS\s*\((\S+)\)/g) { |
21 | while (/ACC_CLASS\s*\((\S+)\)/g) { |
18 | $curclass = $1; |
22 | $curclass = $1; |
19 | } |
23 | } |
20 | } |
24 | } |
21 | } |
25 | } |
22 | |
26 | |
23 | exit unless @member; |
27 | if (@scalar_member) { |
|
|
28 | print "SV *$scalar_member[0][1] ($class *self, SV *newval = 0)\n"; |
|
|
29 | print "\tPROTOTYPE: \$;\$\n"; |
24 | |
30 | |
25 | print "SV *$member[0][1] ($class *self, SV *newval = 0)\n"; |
31 | if (@scalar_member > 1) { |
26 | print "\tPROTOTYPE: \$;\$\n"; |
32 | print "\tALIAS:\n"; |
|
|
33 | for (1 .. $#scalar_member) { |
|
|
34 | print "\t\t$scalar_member[$_][1]\t= $_\n"; |
|
|
35 | } |
|
|
36 | } |
27 | |
37 | |
28 | if (@member > 1) { |
|
|
29 | print "\tALIAS:\n"; |
38 | print "\tCODE:\n"; |
30 | for (1 .. $#member) { |
39 | |
31 | print "\t\t$member[$_][1]\t= $_\n"; |
40 | # read |
32 | } |
41 | print "\tif (GIMME_V == G_VOID)\n", |
|
|
42 | "\t RETVAL = &PL_sv_undef;\n", |
|
|
43 | "\telse\n", |
|
|
44 | "\t switch (ix)\n", |
|
|
45 | "\t {\n", |
|
|
46 | (map "\t case $_: RETVAL = to_sv (self->$scalar_member[$_][1]); break;\n", |
|
|
47 | 0 .. $#scalar_member), |
|
|
48 | "\t default: croak (\"scalar_member is write-only\");\n", |
|
|
49 | "\t };\n"; |
|
|
50 | |
|
|
51 | # write |
|
|
52 | print "\tif (newval)\n", |
|
|
53 | "\t switch (ix)\n", |
|
|
54 | "\t {\n", |
|
|
55 | (map "\t case $_: sv_to (newval, self->$scalar_member[$_][1]); break;\n", |
|
|
56 | grep $scalar_member[$_][0] eq "W", |
|
|
57 | 0 .. $#scalar_member), |
|
|
58 | "\t default: croak (\"scalar_member is read-only\");\n", |
|
|
59 | "\t };\n"; |
|
|
60 | |
|
|
61 | print "\tOUTPUT: RETVAL\n\n"; |
33 | } |
62 | } |
34 | |
63 | |
|
|
64 | if (@array_member) { |
|
|
65 | print "SV *$array_member[0][1] ($class *self, int idx, SV *newval = 0)\n"; |
|
|
66 | print "\tPROTOTYPE: \$;\$\n"; |
|
|
67 | |
|
|
68 | if (@array_member > 1) { |
|
|
69 | print "\tALIAS:\n"; |
|
|
70 | for (1 .. $#array_member) { |
|
|
71 | print "\t\t$array_member[$_][1]\t= $_\n"; |
|
|
72 | } |
|
|
73 | } |
|
|
74 | |
35 | print "\tCODE:\n"; |
75 | print "\tCODE:\n"; |
|
|
76 | |
|
|
77 | print "\tif (idx < 0) croak (\"negative array index\");\n"; |
|
|
78 | |
|
|
79 | # range |
|
|
80 | print "\t switch (ix)\n", |
|
|
81 | "\t {\n", |
|
|
82 | (map "\t case $_: if (idx >= $array_member[$_][2]) croak (\"array index out of bounds\"); break;\n", |
|
|
83 | 0 .. $#array_member), |
|
|
84 | "\t };\n"; |
36 | |
85 | |
37 | # read |
86 | # read |
38 | print "\tif (GIMME_V == G_VOID)\n", |
87 | print "\tif (GIMME_V == G_VOID)\n", |
39 | "\t RETVAL = &PL_sv_undef;\n", |
88 | "\t RETVAL = &PL_sv_undef;\n", |
40 | "\telse\n", |
89 | "\telse\n", |
41 | "\t switch (ix)\n", |
90 | "\t switch (ix)\n", |
42 | "\t {\n", |
91 | "\t {\n", |
43 | (map "\t case $_: RETVAL = to_sv (self->$member[$_][1]); break;\n", |
92 | (map "\t case $_: RETVAL = to_sv (self->$array_member[$_][1] [idx]); break;\n", |
44 | 0 .. $#member), |
93 | 0 .. $#array_member), |
45 | "\t default: croak (\"member is write-only\");\n", |
94 | "\t default: croak (\"array_member is write-only\");\n", |
46 | "\t };\n"; |
95 | "\t };\n"; |
47 | |
96 | |
48 | # write |
97 | # write |
49 | print "\tif (newval)\n", |
98 | print "\tif (newval)\n", |
50 | "\t switch (ix)\n", |
99 | "\t switch (ix)\n", |
51 | "\t {\n", |
100 | "\t {\n", |
52 | (map "\t case $_: sv_to (newval, self->$member[$_][1]); break;\n", |
101 | (map "\t case $_: sv_to (newval, self->$array_member[$_][1] [idx]); break;\n", |
53 | grep $member[$_][0] eq "W", |
102 | grep $array_member[$_][0] eq "W", |
54 | 0 .. $#member), |
103 | 0 .. $#array_member), |
55 | "\t default: croak (\"member is read-only\");\n", |
104 | "\t default: croak (\"array_member is read-only\");\n", |
56 | "\t };\n"; |
105 | "\t };\n"; |
57 | |
106 | |
58 | print "\tOUTPUT: RETVAL\n"; |
107 | print "\tOUTPUT: RETVAL\n\n"; |
|
|
108 | } |
59 | |
109 | |