source: trunk/essentials/dev-lang/perl/jpl/JPL/AutoLoader.pm@ 3314

Last change on this file since 3314 was 3181, checked in by bird, 19 years ago

perl 5.8.8
File size: 8.3 KB
Line 
1package JPL::AutoLoader;
2
3use strict;
4
5use vars qw(@ISA @EXPORT $AUTOLOAD);
6
7use Exporter;
8@ISA = "Exporter";
9@EXPORT = ("AUTOLOAD", "getmeth");
10
11my %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#
29my %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#
45my %MID_CACHE;
46
47# A cache for methods.
48#
49# bjepson 13 August 1997
50#
51my %METHOD_CACHE;
52
53use JNI;
54
55# XXX We're assuming for the moment that method ids are persistent...
56
57sub 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';
195package $blesspack;
196END
197use JPL::AutoLoader;
198use overload
199 '""' => sub { JNI::GetStringUTFChars($_[0]) },
200 '0+' => sub { 0 + "$_[0]" },
201 fallback => 1;
202ENDQ
203 }
204 else {
205 eval <<"END";
206package $blesspack;
207use JPL::AutoLoader;
208END
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
284sub 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
315sub 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}
3521;
Note: See TracBrowser for help on using the repository browser.