home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / jpl / JPL / AutoLoader.pm next >
Text File  |  1999-09-14  |  8KB  |  353 lines
  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;
  353.