jpl/JPL/AutoLoader.pm

   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;