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