Commit | Line | Data |
d50cb536 |
1 | package JPL::AutoLoader; |
2 | |
3 | use strict; |
4 | |
5 | use vars qw(@ISA @EXPORT $AUTOLOAD); |
6 | |
7 | use Exporter; |
8 | @ISA = "Exporter"; |
9 | @EXPORT = ("AUTOLOAD", "getmeth"); |
10 | |
11 | my %callmethod = ( |
12 | V => 'Void', |
13 | Z => 'Boolean', |
14 | B => 'Byte', |
15 | C => 'Char', |
16 | S => 'Short', |
17 | I => 'Int', |
18 | J => 'Long', |
19 | F => 'Float', |
20 | D => 'Double', |
21 | ); |
22 | |
23 | # A lookup table to convert the data types that Java |
24 | # developers are used to seeing into the JNI-mangled |
25 | # versions. |
26 | # |
27 | # bjepson 13 August 1997 |
28 | # |
29 | my %type_table = ( |
30 | 'void' => 'V', |
31 | 'boolean' => 'Z', |
32 | 'byte' => 'B', |
33 | 'char' => 'C', |
34 | 'short' => 'S', |
35 | 'int' => 'I', |
36 | 'long' => 'J', |
37 | 'float' => 'F', |
38 | 'double' => 'D' |
39 | ); |
40 | |
41 | # A cache for method ids. |
42 | # |
43 | # bjepson 13 August 1997 |
44 | # |
45 | my %MID_CACHE; |
46 | |
47 | # A cache for methods. |
48 | # |
49 | # bjepson 13 August 1997 |
50 | # |
51 | my %METHOD_CACHE; |
52 | |
53 | use JNI; |
54 | |
55 | # XXX We're assuming for the moment that method ids are persistent... |
56 | |
57 | sub AUTOLOAD { |
58 | |
59 | print "AUTOLOAD $AUTOLOAD(@_)\n" if $JPL::DEBUG; |
60 | my ($classname, $methodsig) = $AUTOLOAD =~ /^(.*)::(.*)/; |
61 | print "class = $classname, method = $methodsig\n" if $JPL::DEBUG; |
62 | |
63 | if ($methodsig eq "DESTROY") { |
64 | print "sub $AUTOLOAD {}\n" if $JPL::DEBUG; |
65 | eval "sub $AUTOLOAD {}"; |
66 | return; |
67 | } |
68 | |
69 | (my $jclassname = $classname) =~ s/^JPL:://; |
70 | $jclassname =~ s{::}{/}g; |
71 | my $class = JNI::FindClass($jclassname) |
72 | or die "Can't find Java class $jclassname\n"; |
73 | |
74 | # This method lookup allows the user to pass in |
75 | # references to two array that contain the input and |
76 | # output data types of the method. |
77 | # |
78 | # bjepson 13 August 1997 |
79 | # |
80 | my ($methodname, $sig, $retsig, $slow_way); |
81 | if (ref $_[1] eq 'ARRAY' && ref $_[2] eq 'ARRAY') { |
82 | |
83 | $slow_way = 1; |
84 | |
85 | # First we strip out the input and output args. |
86 | # |
87 | my ($in,$out) = splice(@_, 1, 2); |
88 | |
89 | # let's mangle up the input argument types. |
90 | # |
91 | my @in = jni_mangle($in); |
92 | |
93 | # if they didn't hand us any output values types, make |
94 | # them void by default. |
95 | # |
96 | unless (@{ $out }) { |
97 | $out = ['void']; |
98 | } |
99 | |
100 | # mangle the output types |
101 | # |
102 | my @out = jni_mangle($out); |
103 | |
104 | $methodname = $methodsig; |
105 | $retsig = join("", @out); |
106 | $sig = "(" . join("", @in) . ")" . $retsig; |
107 | |
108 | } else { |
109 | |
110 | ($methodname, $sig) = split /__/, $methodsig, 2; |
111 | $sig ||= "__V"; # default is void return |
112 | |
113 | # Now demangle the signature. |
114 | |
115 | $sig =~ s/_3/[/g; |
116 | $sig =~ s/_2/;/g; |
117 | my $tmp; |
118 | $sig =~ s{ |
119 | (s|L[^;]*;) |
120 | }{ |
121 | $1 eq 's' |
122 | ? "Ljava/lang/String;" |
123 | : (($tmp = $1) =~ tr[_][/], $tmp) |
124 | }egx; |
125 | if ($sig =~ s/(.*)__(.*)/($1)$2/) { |
126 | $retsig = $2; |
127 | } |
128 | else { # void return is assumed |
129 | $sig = "($sig)V"; |
130 | $retsig = "V"; |
131 | } |
132 | $sig =~ s/_1/_/g; |
133 | } |
134 | print "sig = $sig\n" if $JPL::DEBUG; |
135 | |
136 | # Now look up the method's ID somehow or other. |
137 | # |
138 | $methodname = "<init>" if $methodname eq 'new'; |
139 | my $mid; |
140 | |
141 | # Added a method id cache to compensate for avoiding |
142 | # Perl's method cache... |
143 | # |
144 | if ($MID_CACHE{qq[$classname:$methodname:$sig]}) { |
145 | |
146 | $mid = $MID_CACHE{qq[$classname:$methodname:$sig]}; |
147 | print "got method " . ($mid + 0) . " from cache.\n" if $JPL::DEBUG; |
148 | |
149 | } elsif (ref $_[0] or $methodname eq '<init>') { |
150 | |
151 | # Look up an instance method or a constructor |
152 | # |
153 | $mid = JNI::GetMethodID($class, $methodname, $sig); |
154 | |
155 | } else { |
156 | |
157 | # Look up a static method |
158 | # |
159 | $mid = JNI::GetStaticMethodID($class, $methodname, $sig); |
160 | |
161 | } |
162 | |
163 | # Add this method to the cache. |
164 | # |
165 | # bjepson 13 August 1997 |
166 | # |
167 | $MID_CACHE{qq[$classname:$methodname:$sig]} = $mid if $slow_way; |
168 | |
169 | if ($mid == 0) { |
170 | |
171 | JNI::ExceptionClear(); |
172 | # Could do some guessing here on return type... |
173 | die "Can't get method id for $AUTOLOAD($sig)\n"; |
174 | |
175 | } |
176 | |
177 | print "mid = ", $mid + 0, ", $mid\n" if $JPL::DEBUG; |
178 | my $rettype = $callmethod{$retsig} || "Object"; |
179 | print "*** rettype = $rettype\n" if $JPL::DEBUG; |
180 | |
181 | my $blesspack; |
182 | no strict 'refs'; |
183 | if ($rettype eq "Object") { |
184 | $blesspack = $retsig; |
185 | $blesspack =~ s/^L//; |
186 | $blesspack =~ s/;$//; |
187 | $blesspack =~ s#/#::#g; |
188 | print "*** Some sort of wizardry...\n" if $JPL::DEBUG; |
189 | print %{$blesspack . "::"}, "\n" if $JPL::DEBUG; |
190 | print defined %{$blesspack . "::"}, "\n" if $JPL::DEBUG; |
191 | if (not defined %{$blesspack . "::"}) { |
192 | #if ($blesspack eq "java::lang::String") { |
193 | if ($blesspack =~ /java::/) { |
194 | eval <<"END" . <<'ENDQ'; |
195 | package $blesspack; |
196 | END |
197 | use JPL::AutoLoader; |
198 | use overload |
199 | '""' => sub { JNI::GetStringUTFChars($_[0]) }, |
200 | '0+' => sub { 0 + "$_[0]" }, |
201 | fallback => 1; |
202 | ENDQ |
203 | } |
204 | else { |
205 | eval <<"END"; |
206 | package $blesspack; |
207 | use JPL::AutoLoader; |
208 | END |
209 | } |
210 | } |
211 | } |
212 | |
213 | # Finally, call the method. Er, somehow... |
214 | # |
215 | my $METHOD; |
216 | |
217 | my $real_mid = $mid + 0; # weird overloading that I |
218 | # don't understand ?! |
219 | if (ref ${$METHOD_CACHE{qq[$real_mid]}} eq 'CODE') { |
220 | |
221 | $METHOD = ${$METHOD_CACHE{qq[$real_mid]}}; |
222 | print qq[Pulled $classname, $methodname, $sig from cache.\n] if $JPL::DEBUG; |
223 | |
224 | } elsif ($methodname eq "<init>") { |
225 | $METHOD = sub { |
226 | my $self = shift; |
227 | my $class = JNI::FindClass($jclassname); |
228 | bless $class->JNI::NewObjectA($mid, \@_), $classname; |
229 | }; |
230 | } |
231 | elsif (ref $_[0]) { |
232 | if ($blesspack) { |
233 | $METHOD = sub { |
234 | my $self = shift; |
235 | if (ref $self eq $classname) { |
236 | my $callmethod = "JNI::Call${rettype}MethodA"; |
237 | bless $self->$callmethod($mid, \@_), $blesspack; |
238 | } |
239 | else { |
240 | my $callmethod = "JNI::CallNonvirtual${rettype}MethodA"; |
241 | bless $self->$callmethod($class, $mid, \@_), $blesspack; |
242 | } |
243 | }; |
244 | } |
245 | else { |
246 | $METHOD = sub { |
247 | my $self = shift; |
248 | if (ref $self eq $classname) { |
249 | my $callmethod = "JNI::Call${rettype}MethodA"; |
250 | $self->$callmethod($mid, \@_); |
251 | } |
252 | else { |
253 | my $callmethod = "JNI::CallNonvirtual${rettype}MethodA"; |
254 | $self->$callmethod($class, $mid, \@_); |
255 | } |
256 | }; |
257 | } |
258 | } |
259 | else { |
260 | my $callmethod = "JNI::CallStatic${rettype}MethodA"; |
261 | if ($blesspack) { |
262 | $METHOD = sub { |
263 | my $self = shift; |
264 | bless $class->$callmethod($mid, \@_), $blesspack; |
265 | }; |
266 | } |
267 | else { |
268 | $METHOD = sub { |
269 | my $self = shift; |
270 | $class->$callmethod($mid, \@_); |
271 | }; |
272 | } |
273 | } |
274 | if ($slow_way) { |
275 | $METHOD_CACHE{qq[$real_mid]} = \$METHOD; |
276 | &$METHOD; |
277 | } |
278 | else { |
279 | *$AUTOLOAD = $METHOD; |
280 | goto &$AUTOLOAD; |
281 | } |
282 | } |
283 | |
284 | sub jni_mangle { |
285 | |
286 | my $arr = shift; |
287 | my @ret; |
288 | |
289 | foreach my $arg (@{ $arr }) { |
290 | |
291 | my $ret; |
292 | |
293 | # Count the dangling []s. |
294 | # |
295 | $ret = '[' x $arg =~ s/\[\]//g; |
296 | |
297 | # Is it a primitive type? |
298 | # |
299 | if ($type_table{$arg}) { |
300 | $ret .= $type_table{$arg}; |
301 | } else { |
302 | # some sort of class |
303 | # |
304 | $arg =~ s#\.#/#g; |
305 | $ret .= "L$arg;"; |
306 | } |
307 | push @ret, $ret; |
308 | |
309 | } |
310 | |
311 | return @ret; |
312 | |
313 | } |
314 | |
315 | sub getmeth { |
316 | my ($meth, $in, $out) = @_; |
317 | my @in = jni_mangle($in); |
318 | |
319 | # if they didn't hand us any output values types, make |
320 | # them void by default. |
321 | # |
322 | unless ($out and @$out) { |
323 | $out = ['void']; |
324 | } |
325 | |
326 | # mangle the output types |
327 | # |
328 | my @out = jni_mangle($out); |
329 | |
330 | my $sig = join("", '#', @in, '#', @out); |
331 | $sig =~ s/_/_1/g; |
332 | my $tmp; |
333 | $sig =~ s{ |
334 | (L[^;]*;) |
335 | }{ |
336 | ($tmp = $1) =~ tr[/][_], $tmp |
337 | }egx; |
338 | $sig =~ s{Ljava/lang/String;}{s}g; |
339 | $sig =~ s/;/_2/g; |
340 | $sig =~ s/\[/_3/g; |
341 | $sig =~ s/#/__/g; |
342 | $meth . $sig; |
343 | } |
344 | |
345 | { |
346 | package java::lang::String; |
347 | use overload |
348 | '""' => sub { JNI::GetStringUTFChars($_[0]) }, |
349 | '0+' => sub { 0 + "$_[0]" }, |
350 | fallback => 1; |
351 | } |
352 | 1; |