| 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; |
projects / p5sagit/p5-mst-13.2.git / blame