branch jpl from perlext to perl

p4raw-id: //depot/perl@2410

4 files changed, 1170 insertions, 0 deletions

diff --git a/jpl/JPL/AutoLoader.pm b/jpl/JPL/AutoLoader.pm
new file mode 100644
index 0000000000..94d98563fd
--- /dev/null
+++ b/jpl/JPL/AutoLoader.pm
@@ -0,0 +1,352 @@
+package JPL::AutoLoader;
+
+use strict;
+
+use vars qw(@ISA @EXPORT $AUTOLOAD);
+
+use Exporter;
+@ISA = "Exporter";
+@EXPORT = ("AUTOLOAD", "getmeth");
+
+my %callmethod = (
+    V => 'Void',
+    Z => 'Boolean',
+    B => 'Byte',
+    C => 'Char',
+    S => 'Short',
+    I => 'Int',
+    J => 'Long',
+    F => 'Float',
+    D => 'Double',
+);
+
+# A lookup table to convert the data types that Java
+# developers are used to seeing into the JNI-mangled
+# versions.
+#
+# bjepson 13 August 1997
+#
+my %type_table = (
+    'void'    => 'V',
+    'boolean' => 'Z',
+    'byte'    => 'B',
+    'char'    => 'C',
+    'short'   => 'S',
+    'int'     => 'I',
+    'long'    => 'J',
+    'float'   => 'F',
+    'double'  => 'D'
+);
+
+# A cache for method ids.
+#
+# bjepson 13 August 1997
+#
+my %MID_CACHE;
+
+# A cache for methods.
+#
+# bjepson 13 August 1997
+#
+my %METHOD_CACHE;
+
+use JNI;
+
+# XXX We're assuming for the moment that method ids are persistent...
+
+sub AUTOLOAD {
+
+    print "AUTOLOAD $AUTOLOAD(@_)\n" if $JPL::DEBUG;
+    my ($classname, $methodsig) = $AUTOLOAD =~ /^(.*)::(.*)/;
+    print "class = $classname, method = $methodsig\n" if $JPL::DEBUG;
+
+    if ($methodsig eq "DESTROY") {
+        print "sub $AUTOLOAD {}\n" if $JPL::DEBUG;
+        eval "sub $AUTOLOAD {}";
+        return;
+    }
+
+    (my $jclassname = $classname) =~ s/^JPL:://;
+    $jclassname =~ s{::}{/}g;
+    my $class = JNI::FindClass($jclassname)
+        or die "Can't find Java class $jclassname\n";
+
+    # This method lookup allows the user to pass in
+    # references to two array that contain the input and
+    # output data types of the method.
+    #
+    # bjepson 13 August 1997
+    #
+    my ($methodname, $sig, $retsig, $slow_way);
+    if (ref $_[1] eq 'ARRAY' && ref $_[2] eq 'ARRAY') {
+
+	$slow_way = 1;
+
+        # First we strip out the input and output args.
+	#
+        my ($in,$out) = splice(@_, 1, 2);
+
+        # let's mangle up the input argument types.
+        #
+        my @in  = jni_mangle($in);
+
+        # if they didn't hand us any output values types, make
+        # them void by default.
+        #
+        unless (@{ $out }) {
+            $out = ['void'];
+        }
+
+        # mangle the output types
+        #
+        my @out = jni_mangle($out);
+
+        $methodname = $methodsig;
+        $retsig     = join("", @out);
+        $sig        = "(" . join("", @in) . ")" . $retsig;
+
+    } else {
+
+        ($methodname, $sig) = split /__/, $methodsig, 2;
+        $sig ||= "__V";                # default is void return
+
+        # Now demangle the signature.
+
+        $sig =~ s/_3/[/g;
+        $sig =~ s/_2/;/g;
+        my $tmp;
+        $sig =~ s{
+            (s|L[^;]*;)
+        }{
+	    $1 eq 's'
+		? "Ljava/lang/String;"
+		: (($tmp = $1) =~ tr[_][/], $tmp)
+        }egx;
+        if ($sig =~ s/(.*)__(.*)/($1)$2/) {
+            $retsig = $2;
+        }
+        else {                        # void return is assumed
+            $sig = "($sig)V";
+            $retsig = "V";
+        }
+        $sig =~ s/_1/_/g;
+    }
+    print "sig = $sig\n" if $JPL::DEBUG;
+
+    # Now look up the method's ID somehow or other.
+    #
+    $methodname = "<init>" if $methodname eq 'new';
+    my $mid;
+
+    # Added a method id cache to compensate for avoiding
+    # Perl's method cache...
+    #
+    if ($MID_CACHE{qq[$classname:$methodname:$sig]}) {
+
+        $mid = $MID_CACHE{qq[$classname:$methodname:$sig]};
+        print "got method " . ($mid + 0) . " from cache.\n" if $JPL::DEBUG;
+
+    } elsif (ref $_[0] or $methodname eq '<init>') {
+
+        # Look up an instance method or a constructor
+        #
+        $mid = JNI::GetMethodID($class, $methodname, $sig);
+
+    } else {
+
+        # Look up a static method
+        #
+        $mid = JNI::GetStaticMethodID($class, $methodname, $sig);
+
+    }
+
+    # Add this method to the cache.
+    #
+    # bjepson 13 August 1997
+    #
+    $MID_CACHE{qq[$classname:$methodname:$sig]} = $mid if $slow_way;
+
+    if ($mid == 0) {
+
+        JNI::ExceptionClear();
+        # Could do some guessing here on return type...
+        die "Can't get method id for $AUTOLOAD($sig)\n";
+
+    }
+
+    print "mid = ", $mid + 0, ", $mid\n" if $JPL::DEBUG;
+    my $rettype = $callmethod{$retsig} || "Object";
+    print "*** rettype = $rettype\n" if $JPL::DEBUG;
+
+    my $blesspack;
+    no strict 'refs';
+    if ($rettype eq "Object") {
+        $blesspack = $retsig;
+        $blesspack =~ s/^L//;
+        $blesspack =~ s/;$//;
+        $blesspack =~ s#/#::#g;
+        print "*** Some sort of wizardry...\n" if $JPL::DEBUG;
+        print %{$blesspack . "::"}, "\n" if $JPL::DEBUG;
+        print defined %{$blesspack . "::"}, "\n" if $JPL::DEBUG;
+        if (not defined %{$blesspack . "::"}) {
+            #if ($blesspack eq "java::lang::String") {
+            if ($blesspack =~ /java::/) {
+                eval <<"END" . <<'ENDQ';
+package $blesspack;
+END
+use JPL::AutoLoader;
+use overload
+        '""' => sub { JNI::GetStringUTFChars($_[0]) },
+        '0+' => sub { 0 + "$_[0]" },
+        fallback => 1;
+ENDQ
+            }
+            else {
+                eval <<"END";
+package $blesspack;
+use JPL::AutoLoader;
+END
+            }
+        }
+    }
+
+    # Finally, call the method.  Er, somehow...
+    #
+    my $METHOD;
+
+    my $real_mid = $mid + 0; # weird overloading that I
+                             # don't understand ?!
+    if (ref ${$METHOD_CACHE{qq[$real_mid]}} eq 'CODE') {
+
+        $METHOD = ${$METHOD_CACHE{qq[$real_mid]}};
+        print qq[Pulled $classname, $methodname, $sig from cache.\n] if $JPL::DEBUG;
+
+    } elsif ($methodname eq "<init>") {
+        $METHOD = sub {
+            my $self = shift;
+	    my $class = JNI::FindClass($jclassname);
+            bless $class->JNI::NewObjectA($mid, \@_), $classname;
+        };
+    }
+    elsif (ref $_[0]) {
+        if ($blesspack) {
+            $METHOD = sub {
+                my $self = shift;
+                if (ref $self eq $classname) {
+                    my $callmethod = "JNI::Call${rettype}MethodA";
+                    bless $self->$callmethod($mid, \@_), $blesspack;
+                }
+                else {
+                    my $callmethod = "JNI::CallNonvirtual${rettype}MethodA";
+                    bless $self->$callmethod($class, $mid, \@_), $blesspack;
+                }
+            };
+        }
+        else {
+            $METHOD = sub {
+                my $self = shift;
+                if (ref $self eq $classname) {
+                    my $callmethod = "JNI::Call${rettype}MethodA";
+                    $self->$callmethod($mid, \@_);
+                }
+                else {
+                    my $callmethod = "JNI::CallNonvirtual${rettype}MethodA";
+                    $self->$callmethod($class, $mid, \@_);
+                }
+            };
+        }
+    }
+    else {
+        my $callmethod = "JNI::CallStatic${rettype}MethodA";
+        if ($blesspack) {
+            $METHOD = sub {
+                my $self = shift;
+                bless $class->$callmethod($mid, \@_), $blesspack;
+            };
+        }
+        else {
+            $METHOD = sub {
+                my $self = shift;
+                $class->$callmethod($mid, \@_);
+            };
+        }
+    }
+    if ($slow_way) {
+	$METHOD_CACHE{qq[$real_mid]} = \$METHOD;
+	&$METHOD;
+    }
+    else {
+	*$AUTOLOAD = $METHOD;
+	goto &$AUTOLOAD;
+    }
+}
+
+sub jni_mangle {
+
+    my $arr = shift;
+    my @ret;
+
+    foreach my $arg (@{ $arr }) {
+
+        my $ret;
+
+        # Count the dangling []s.
+        #
+	$ret = '[' x $arg =~ s/\[\]//g;
+
+        # Is it a primitive type?
+        #
+        if ($type_table{$arg}) {
+            $ret .= $type_table{$arg};
+        } else {
+            # some sort of class
+            #
+            $arg =~ s#\.#/#g;
+            $ret .= "L$arg;";
+        }
+        push @ret, $ret;
+
+    }
+
+    return @ret;
+
+}
+
+sub getmeth {
+    my ($meth, $in, $out) = @_;
+    my @in  = jni_mangle($in);
+
+    # if they didn't hand us any output values types, make
+    # them void by default.
+    #
+    unless ($out and @$out) {
+	$out = ['void'];
+    }
+
+    # mangle the output types
+    #
+    my @out = jni_mangle($out);
+
+    my $sig        = join("", '#', @in, '#', @out);
+    $sig =~ s/_/_1/g;
+    my $tmp;
+    $sig =~ s{
+	(L[^;]*;)
+    }{
+	($tmp = $1) =~ tr[/][_], $tmp
+    }egx;
+    $sig =~ s{Ljava/lang/String;}{s}g;
+    $sig =~ s/;/_2/g;
+    $sig =~ s/\[/_3/g;
+    $sig =~ s/#/__/g;
+    $meth . $sig;
+}
+
+{
+    package java::lang::String;
+    use overload
+	'""' => sub { JNI::GetStringUTFChars($_[0]) },
+	'0+' => sub { 0 + "$_[0]" },
+	fallback => 1;
+}
+1;
diff --git a/jpl/JPL/Class.pm b/jpl/JPL/Class.pm
new file mode 100644
index 0000000000..1bc97688a8
--- /dev/null
+++ b/jpl/JPL/Class.pm
@@ -0,0 +1,13 @@
+package JPL::Class;
+use JPL::AutoLoader ();
+
+sub DESTROY {}
+
+sub import {
+    my $class = shift;
+    foreach $class (@_) {
+	*{$class . "::AUTOLOAD"} = *JPL::AutoLoader::AUTOLOAD;
+	*{$class . "::DESTROY"} = \&DESTROY;
+    }
+}
+1;
diff --git a/jpl/JPL/Compile.pm b/jpl/JPL/Compile.pm
new file mode 100755
index 0000000000..6d9511245e
--- /dev/null
+++ b/jpl/JPL/Compile.pm
@@ -0,0 +1,769 @@
+#!/usr/bin/perl -w
+
+# Copyright 1997, O'Reilly & Associate, Inc.
+#
+# This package may be copied under the same terms as Perl itself.
+
+package JPL::Compile;
+use Exporter ();
+@ISA = qw(Exporter);
+@EXPORT = qw(files file);
+
+use strict;
+
+
+warn "You don't have a recent JDK kit your PATH, so this may fail.\n"
+    unless $ENV{PATH} =~ /(java|jdk1.[1-9])/;
+
+sub emit;
+
+my $PERL = "";
+my $LASTCLASS = "";
+my $PERLLINE = 0;
+my $PROTO;
+
+my @protos;
+
+my $plfile;
+my $jpfile;
+my $hfile;
+my $h_file;
+my $cfile;
+my $jfile;
+my $classfile;
+
+my $DEBUG = $ENV{JPLDEBUG};
+
+my %ptype = qw(
+	Z boolean
+	B byte
+	C char
+	S short
+	I int
+	J long
+	F float
+	D double
+);
+
+$ENV{CLASSPATH} =~ s/^/.:/ unless $ENV{CLASSPATH} =~ /^\.(?::|$)/;
+
+unless (caller) {
+    files(@ARGV);
+}
+
+#######################################################################
+
+sub files {
+    foreach my $jpfile (@_) {
+	file($jpfile);
+    }
+    print "make\n";
+    system "make";
+}
+
+sub file {
+    my $jpfile = shift;
+    my $JAVA = "";
+    my $lastpos = 0;
+    my $linenum = 2;
+    my %classseen;
+    my %fieldsig;
+    my %staticfield;
+
+    (my $file = $jpfile) =~ s/\.jpl$//;
+    $jpfile = "$file.jpl";
+    $jfile = "$file.java";
+    $hfile = "$file.h";
+    $cfile = "$file.c";
+    $plfile = "$file.pl";
+    $classfile = "$file.class";
+
+    ($h_file = $hfile) =~ s/_/_0005f/g;
+
+    emit_c_header();
+
+    # Extract out arg names from .java file, since .class doesn't have 'em.
+
+    open(JPFILE, $jpfile) or die "Can't open $jpfile: $!\n";
+    undef $/;
+    $_ = <JPFILE>;
+    close JPFILE;
+
+    die "$jpfile doesn't seem to define class $file!\n"
+	unless /class\s+\b$file\b[\w\s.,]*{/;
+
+    @protos = ();
+    open(JFILE, ">$jfile") or die "Can't create $jfile: $!\n";
+
+    while (m/\bperl\b([^\n]*?\b(\w+)\s*\(\s*(.*?)\s*\)[\s\w.,]*)\{\{(.*?)\}\}/sg) {
+	$JAVA = substr($`, $lastpos);
+	$lastpos = pos $_;
+	$JAVA .= "native";
+	$JAVA .= $1;
+
+	my $method = $2;
+
+	my $proto = $3;
+
+	my $perl = $4;
+	(my $repl = $4) =~ tr/\n//cd;
+	$JAVA .= ';';
+	$linenum += $JAVA =~ tr/\n/\n/;
+	$JAVA .= $repl;
+	print JFILE $JAVA;
+
+	$proto =~ s/\s+/ /g;
+	$perl =~ s/^[ \t]+\Z//m;
+	$perl =~ s/^[ \t]*\n//;
+	push(@protos, [$method, $proto, $perl, $linenum]);
+
+	$linenum += $repl =~ tr/\n/\n/;
+    }
+
+    print JFILE <<"END";
+    static {
+	System.loadLibrary("$file");
+        PerlInterpreter pi = new PerlInterpreter().fetch();
+        // pi.eval("\$JPL::DEBUG = \$ENV{JPLDEBUG};");
+	pi.eval("warn qq{loading $file\\n} if \$JPL::DEBUG");
+	pi.eval("eval {require '$plfile'}; print \$@ if \$@;");
+    }
+END
+
+    print JFILE substr($_, $lastpos);
+
+    close JFILE;
+
+    # Produce the corresponding .h file.  Should really use make...
+
+    if (not -s $hfile or -M $hfile > -M $jfile) {
+	if (not -s $classfile or -M $classfile > -M $jfile) {
+	    unlink $classfile;
+	    print  "javac $jfile\n";
+	    system "javac $jfile" and die "Couldn't run javac: exit $?\n";
+	    if (not -s $classfile or -M $classfile > -M $jfile) {
+		die "Couldn't produce $classfile from $jfile!";
+	    }
+	}
+	unlink $hfile;
+	print  "javah -jni $file\n";
+	system "javah -jni $file" and die "Couldn't run javah: exit $?\n";
+	if (not -s $hfile and -s $h_file) {
+	    rename $h_file, $hfile;
+	}
+	if (not -s $hfile or -M $hfile > -M $jfile) {
+	    die "Couldn't produce $hfile from $classfile!";
+	}
+    }
+
+    # Easiest place to get fields is from javap.
+
+    print  "javap -s $file\n";
+    open(JP, "javap -s $file|");
+    $/ = "\n";
+    while (<JP>) {
+	if (/^\s+([A-Za-z_].*) (\w+)[\[\d\]]*;/) {
+	    my $jtype = $1;
+	    my $name = $2;
+	    $_ = <JP>;
+	    s!^\s*/\*\s*!!;
+	    s!\s*\*/\s*!!;
+	    print "Field $jtype $name $_\n" if $DEBUG;
+	    $fieldsig{$name} = $_;
+	    $staticfield{$name} = $jtype =~ /\bstatic\b/;
+	}
+	while (m/L([^;]*);/g) {
+	    my $pclass = j2p_class($1);
+	    $classseen{$pclass}++;
+	}
+    }
+    close JP;
+
+    open(HFILE, $hfile) or die "Couldn't open $hfile: $!\n";
+    undef $/;
+    $_ = <HFILE>;
+    close HFILE;
+
+    die "panic: native method mismatch" if @protos != s/^JNIEXPORT/JNIEXPORT/gm;
+
+    $PROTO = 0;
+    while (m{
+	\*\s*Class:\s*(\w+)\s*
+	\*\s*Method:\s*(\w+)\s*
+	\*\s*Signature:\s*(\S+)\s*\*/\s*
+	JNIEXPORT\s*(.*?)\s*JNICALL\s*(\w+)\s*\((.*?)\)
+    }gx) {
+	my $class = $1;
+	my $method = $2;
+	my $signature = $3;
+	my $rettype = $4;
+	my $cname = $5;
+	my $ctypes = $6;
+	$class =~ s/_0005f/_/g;
+	if ($method ne $protos[$PROTO][0]) {
+	    die "Method name mismatch: $method vs $protos[$PROTO][0]\n";
+	}
+	print "$class.$method($protos[$PROTO][1]) =>
+	$signature
+	$rettype $cname($ctypes)\n" if $DEBUG;
+
+	# Insert argument names into parameter list.
+
+	my $env = "env";
+	my $obj = "obj";
+	my @jargs = split(/\s*,\s*/, $protos[$PROTO][1]);
+	foreach my $arg (@jargs) {
+	    $arg =~ s/^.*\b(\w+).*$/${1}/;
+	}
+	my @tmpargs = @jargs;
+	unshift(@tmpargs, $env, $obj);
+	print "\t@tmpargs\n" if $DEBUG;
+	$ctypes .= ",";
+	$ctypes =~ s/,/' ' . shift(@tmpargs) . '_,'/eg;
+	$ctypes =~ s/,$//;
+	$ctypes =~ s/env_/env/;
+	$ctypes =~ s/obj_/obj/;
+	print "\t$ctypes\n" if $DEBUG;
+
+	my $jlen = @jargs + 1;
+
+	(my $mangclass = $class) =~ s/_/_1/g;
+	(my $mangmethod = $method) =~ s/_/_1/g;
+	my $plname = $cname;
+	$plname =~ s/^Java_${mangclass}_${mangmethod}/JPL::${class}::${method}/;
+	$plname =~ s/Ljava_lang_String_2/s/g;
+
+	# Make glue code for each argument.
+
+	(my $sig = $signature) =~ s/^\(//;
+
+	my $decls = "";
+	my $glue = "";
+
+	foreach my $jarg (@jargs) {
+	    if ($sig =~ s/^[ZBCSI]//) {
+		$glue .= <<"";
+!    /* $jarg */
+!    PUSHs(sv_2mortal(newSViv(${jarg}_)));
+!
+
+	    }
+	    elsif ($sig =~ s/^[JFD]//) {
+		$glue .= <<"";
+!    /* $jarg */
+!    PUSHs(sv_2mortal(newSVnv(${jarg}_)));
+!
+
+	    }
+	    elsif ($sig =~ s#^Ljava/lang/String;##) {
+		$glue .= <<"";
+!    /* $jarg */
+!    tmpjb = (jbyte*)(*env)->GetStringUTFChars(env,${jarg}_,0);
+!    PUSHs(sv_2mortal(newSVpv((char*)tmpjb,0)));
+!    (*env)->ReleaseStringUTFChars(env,${jarg}_,tmpjb);
+!
+
+	    }
+	    elsif ($sig =~ s/^L([^;]*);//) {
+		my $pclass = j2p_class($1);
+		$classseen{$pclass}++;
+		$glue .= <<"";
+!    /* $jarg */
+!    if (!${jarg}_stashhv_)
+!	${jarg}_stashhv_ = gv_stashpv("$pclass", TRUE);
+! 
+!    PUSHs(sv_bless(
+!	sv_setref_iv(sv_newmortal(), Nullch, (IV)(void*)${jarg}_),
+!	${jarg}_stashhv_));
+!    if (jpldebug)
+!	fprintf(stderr, "Done with $jarg\\n");
+!
+
+		$decls .= <<"";
+!    static HV* ${jarg}_stashhv_ = 0;
+
+
+	    }
+	    elsif ($sig =~ s/^\[+([ZBCSIJFD]|L[^;]*;)//) {
+		my $pclass = "jarray";
+		$classseen{$pclass}++;
+		$glue .= <<"";
+!    /* $jarg */
+!    if (!${jarg}_stashhv_)
+!	${jarg}_stashhv_ = gv_stashpv("$pclass", TRUE);
+! 
+!    PUSHs(sv_bless(
+!	sv_setref_iv(sv_newmortal(), Nullch, (IV)(void*)${jarg}_),
+!	${jarg}_stashhv_));
+!    if (jpldebug)
+!	fprintf(stderr, "Done with $jarg\\n");
+!
+
+		$decls .= <<"";
+!    static HV* ${jarg}_stashhv_ = 0;
+
+	    }
+	    else {
+		die "Short signature: $signature\n" if $sig eq "";
+		die "Unrecognized letter '" . substr($sig, 0, 1) . "' in signature $signature\n";
+	    }
+	}
+
+	$sig =~ s/^\)// or die "Argument mismatch in signature: $method$signature\n";
+
+	my $void = $signature =~ /\)V$/;
+
+	$decls .= <<"" if $signature =~ m#java/lang/String#;
+!    jbyte* tmpjb;
+
+	$decls .= <<"" unless $void;
+!    SV* retsv;
+!    $rettype retval;
+!
+!    if (jpldebug)
+!	fprintf(stderr, "Got to $cname\\n");
+!    ENTER;
+!    SAVETMPS;
+
+	emit <<"";
+!JNIEXPORT $rettype JNICALL
+!$cname($ctypes)
+!{
+!    static SV* methodsv = 0;
+!    static HV* stashhv = 0;
+!    dSP;
+$decls
+!    PUSHMARK(sp);
+!    EXTEND(sp,$jlen);
+!
+!    sv_setiv(perl_get_sv("JPL::_env_", 1), (IV)(void*)env);
+!    jplcurenv = env;
+!
+!    if (jpldebug)
+!	fprintf(stderr, "env = %lx\\n", (long)$env);
+!
+!    if (!methodsv)
+!	methodsv = (SV*)perl_get_cv("$plname", TRUE);
+!    if (!stashhv)
+!	stashhv = gv_stashpv("JPL::$class", TRUE);
+! 
+!    if (jpldebug)
+!	fprintf(stderr, "blessing obj = %lx\\n", obj);
+!    PUSHs(sv_bless(
+!	sv_setref_iv(sv_newmortal(), Nullch, (IV)(void*)obj),
+!	stashhv));
+!
+$glue
+
+	# Finally, call the subroutine.
+
+	my $mod;
+	$mod = "|G_DISCARD" if $void;
+
+	if ($void) {
+	    emit <<"";
+!    PUTBACK;
+!    perl_call_sv(methodsv, G_EVAL|G_KEEPERR|G_DISCARD);
+!
+
+	}
+	else {
+	    emit <<"";
+!    PUTBACK;
+!    if (perl_call_sv(methodsv, G_EVAL|G_KEEPERR))
+!	retsv = *PL_stack_sp--;
+!    else
+!	retsv = &PL_sv_undef;
+!
+
+	}
+
+	emit <<"";
+!    if (SvTRUE(ERRSV)) {
+!	jthrowable newExcCls;
+!
+!	(*env)->ExceptionDescribe(env);
+!	(*env)->ExceptionClear(env);
+!
+!	newExcCls = (*env)->FindClass(env, "java/lang/RuntimeException");
+!	if (newExcCls)
+!	    (*env)->ThrowNew(env, newExcCls, SvPV(ERRSV,PL_na));
+!    }
+!
+
+	# Fix up the return value, if any.
+
+	if ($sig =~ s/^V//) {
+	    emit <<"";
+!    return;
+
+	}
+	elsif ($sig =~ s/^[ZBCSI]//) {
+	    emit <<"";
+!    retval = ($rettype)SvIV(retsv);
+!    FREETMPS;
+!    LEAVE;
+!    return retval;
+
+	}
+	elsif ($sig =~ s/^[JFD]//) {
+	    emit <<"";
+!    retval = ($rettype)SvNV(retsv);
+!    FREETMPS;
+!    LEAVE;
+!    return retval;
+
+	}
+	elsif ($sig =~ s#^Ljava/lang/String;##) {
+	    emit <<"";
+!    retval = (*env)->NewStringUTF(env, SvPV(retsv,PL_na));
+!    FREETMPS;
+!    LEAVE;
+!    return retval;
+
+	}
+	elsif ($sig =~ s/^L[^;]*;//) {
+	    emit <<"";
+!    if (SvROK(retsv)) {
+!	SV* rv = (SV*)SvRV(retsv);
+!	if (SvOBJECT(rv))
+!	    retval = ($rettype)(void*)SvIV(rv);
+!	else
+!	    retval = ($rettype)(void*)0;
+!    }
+!    else
+!	retval = ($rettype)(void*)0;
+!    FREETMPS;
+!    LEAVE;
+!    return retval;
+
+	}
+	elsif ($sig =~ s/^\[([ZBCSIJFD])//) {
+	    my $elemtype = $1;
+	    my $ptype = "\u$ptype{$elemtype}";
+	    my $ntype = "j$ptype{$elemtype}";
+	    my $in = $elemtype =~ /^[JFD]/ ? "N" : "I";
+	    emit <<"";
+!    if (SvROK(retsv)) {
+!	SV* rv = (SV*)SvRV(retsv);
+!	if (SvOBJECT(rv))
+!	    retval = ($rettype)(void*)SvIV(rv);
+!	else if (SvTYPE(rv) == SVt_PVAV) {
+!	    jsize len = av_len((AV*)rv) + 1;
+!	    $ntype* buf = ($ntype*)malloc(len * sizeof($ntype));
+!	    int i;
+!	    SV** esv;
+!
+!	    ${ntype}Array ja = (*env)->New${ptype}Array(env, len);
+!	    for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
+!		buf[i] = ($ntype)Sv${in}V(*esv);
+!	    (*env)->Set${ptype}ArrayRegion(env, ja, 0, len, buf);
+!	    free((void*)buf);
+!	    retval = ($rettype)ja;
+!	}
+!	else
+!	    retval = ($rettype)(void*)0;
+!    }
+!    else if (SvPOK(retsv)) {
+!	jsize len = sv_len(retsv) / sizeof($ntype);
+!
+!	${ntype}Array ja = (*env)->New${ptype}Array(env, len);
+!	(*env)->Set${ptype}ArrayRegion(env, ja, 0, len, ($ntype*)SvPV(retsv,PL_na));
+!	retval = ($rettype)ja;
+!    }
+!    else
+!	retval = ($rettype)(void*)0;
+!    FREETMPS;
+!    LEAVE;
+!    return retval;
+
+	}
+	elsif ($sig =~ s!^\[Ljava/lang/String;!!) {
+	    emit <<"";
+!    if (SvROK(retsv)) {
+!	SV* rv = (SV*)SvRV(retsv);
+!	if (SvOBJECT(rv))
+!	    retval = ($rettype)(void*)SvIV(rv);
+!	else if (SvTYPE(rv) == SVt_PVAV) {
+!	    jsize len = av_len((AV*)rv) + 1;
+!	    int i;
+!	    SV** esv;
+!           static jclass jcl = 0;
+!	    jarray ja;
+!
+!	    if (!jcl)
+!		jcl = (*env)->FindClass(env, "java/lang/String");
+!	    ja = (*env)->NewObjectArray(env, len, jcl, 0);
+!	    for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) {
+!		jobject str = (jobject)(*env)->NewStringUTF(env, SvPV(*esv,PL_na));
+!		(*env)->SetObjectArrayElement(env, ja, i, str);
+!	    }
+!	    retval = ($rettype)ja;
+!	}
+!	else
+!	    retval = ($rettype)(void*)0;
+!    }
+!    else
+!	retval = ($rettype)(void*)0;
+!    FREETMPS;
+!    LEAVE;
+!    return retval;
+
+	}
+	elsif ($sig =~ s/^(\[+)([ZBCSIJFD]|L[^;]*;)//) {
+	    my $arity = length $1;
+	    my $elemtype = $2;
+	    emit <<"";
+!    if (SvROK(retsv)) {
+!	SV* rv = (SV*)SvRV(retsv);
+!	if (SvOBJECT(rv))
+!	    retval = ($rettype)(void*)SvIV(rv);
+!	else if (SvTYPE(rv) == SVt_PVAV) {
+!	    jsize len = av_len((AV*)rv) + 1;
+!	    int i;
+!	    SV** esv;
+!           static jclass jcl = 0;
+!	    jarray ja;
+!
+!	    if (!jcl)
+!		jcl = (*env)->FindClass(env, "java/lang/Object");
+!	    ja = (*env)->NewObjectArray(env, len, jcl, 0);
+!	    for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) {
+!		if (SvROK(*esv) && (rv = SvRV(*esv)) && SvOBJECT(rv)) {
+!		    (*env)->SetObjectArrayElement(env, ja, i,
+!			(jobject)(void*)SvIV(rv));
+!		}
+!		else {
+!		    jobject str = (jobject)(*env)->NewStringUTF(env,
+!			SvPV(*esv,PL_na));
+!		    (*env)->SetObjectArrayElement(env, ja, i, str);
+!		}
+!	    }
+!	    retval = ($rettype)ja;
+!	}
+!	else
+!	    retval = ($rettype)(void*)0;
+!    }
+!    else
+!	retval = ($rettype)(void*)0;
+!    FREETMPS;
+!    LEAVE;
+!    return retval;
+
+	}
+	else {
+	    die "No return type: $signature\n" if $sig eq "";
+	    die "Unrecognized return type '" . substr($sig, 0, 1) . "' in signature $signature\n";
+	}
+
+	emit <<"";
+!}
+!
+
+	my $perl = "";
+
+	if ($class ne $LASTCLASS) {
+	    $LASTCLASS = $class;
+	    $perl .= <<"";
+package JPL::${class};
+use JNI;
+use JPL::AutoLoader;
+\@ISA = qw(jobject);
+\$clazz = JNI::FindClass("$file");\n
+
+	    foreach my $field (sort keys %fieldsig) {
+		my $sig = $fieldsig{$field};
+		my $ptype = $ptype{$sig};
+		if ($ptype) {
+		    $ptype = "\u$ptype";
+		    if ($staticfield{$field}) {
+			$perl .= <<"";
+\$${field}_FieldID = JNI::GetStaticFieldID(\$clazz, "$field", "$sig");
+sub $field (\$;\$) {
+    my \$self = shift;
+    if (\@_) {
+	JNI::SetStatic${ptype}Field(\$clazz, \$${field}_FieldID, \$_[0]);
+    }
+    else {
+	JNI::GetStatic${ptype}Field(\$clazz, \$${field}_FieldID);
+    }
+}\n
+
+		    }
+		    else {
+			$perl .= <<"";
+\$${field}_FieldID = JNI::GetFieldID(\$clazz, "$field", "$sig");
+sub $field (\$;\$) {
+    my \$self = shift;
+    if (\@_) {
+	JNI::Set${ptype}Field(\$self, \$${field}_FieldID, \$_[0]);
+    }
+    else {
+	JNI::Get${ptype}Field(\$self, \$${field}_FieldID);
+    }
+}\n
+
+		    }
+		}
+		else {
+		    my $pltype = $sig;
+		    if ($pltype =~ s/^L(.*);/$1/) {
+			$pltype =~ s!/!::!g;
+		    }
+		    else {
+			$pltype = 'jarray';
+		    }
+		    if ($pltype eq "java::lang::String") {
+			if ($staticfield{$field}) {
+			    $perl .= <<"";
+\$${field}_FieldID = JNI::GetStaticFieldID(\$clazz, "$field", "$sig");
+sub $field (\$;\$) {
+    my \$self = shift;
+    if (\@_) {
+	JNI::SetStaticObjectField(\$clazz, \$${field}_FieldID,
+	    ref \$_[0] ? \$_[0] : JNI::NewStringUTF(\$_[0]));
+    }
+    else {
+	JNI::GetStringUTFChars(JNI::GetStaticObjectField(\$clazz, \$${field}_FieldID));
+    }
+}\n
+
+			}
+			else {
+			    $perl .= <<"";
+\$${field}_FieldID = JNI::GetFieldID(\$clazz, "$field", "$sig");
+sub $field (\$;\$) {
+    my \$self = shift;
+    if (\@_) {
+	JNI::SetObjectField(\$self, \$${field}_FieldID,
+	    ref \$_[0] ? \$_[0] : JNI::NewStringUTF(\$_[0]));
+    }
+    else {
+	JNI::GetStringUTFChars(JNI::GetObjectField(\$self, \$${field}_FieldID));
+    }
+}\n
+
+			}
+		    }
+		    else {
+			if ($staticfield{$field}) {
+			    $perl .= <<"";
+\$${field}_FieldID = JNI::GetStaticFieldID(\$clazz, "$field", "$sig");
+sub $field (\$;\$) {
+    my \$self = shift;
+    if (\@_) {
+	JNI::SetStaticObjectField(\$clazz, \$${field}_FieldID, \$_[0]);
+    }
+    else {
+	bless JNI::GetStaticObjectField(\$clazz, \$${field}_FieldID), "$pltype";
+    }
+}\n
+
+			}
+			else {
+			    $perl .= <<"";
+\$${field}_FieldID = JNI::GetFieldID(\$clazz, "$field", "$sig");
+sub $field (\$;\$) {
+    my \$self = shift;
+    if (\@_) {
+	JNI::SetObjectField(\$self, \$${field}_FieldID, \$_[0]);
+    }
+    else {
+	bless JNI::GetObjectField(\$self, \$${field}_FieldID), "$pltype";
+    }
+}\n
+
+			}
+		    }
+		}
+	    }
+	}
+
+	$plname =~ s/^JPL::${class}:://;
+
+	my $proto = '$' x (@jargs + 1);
+	$perl .= "sub $plname ($proto) {\n";
+	$perl .= '    my ($self, ';
+	foreach my $jarg (@jargs) {
+	    $perl .= "\$$jarg, ";
+	}
+	$perl =~ s/, $/) = \@_;\n/;
+	$perl .= <<"END";
+	warn "JPL::${class}::$plname(\@_)\\n" if \$JPL::DEBUG;
+#line $protos[$PROTO][3] "$jpfile"
+$protos[$PROTO][2]}
+
+END
+
+	$PERLLINE += $perl =~ tr/\n/\n/ + 2;
+	$perl .= <<"END";
+#line $PERLLINE ""
+END
+	$PERLLINE--;
+
+	$PERL .= $perl;
+    }
+    continue {
+	$PROTO++;
+	print "\n" if $DEBUG;
+    }
+
+    emit_c_footer();
+
+    rename $cfile, "$cfile.old";
+    rename "$cfile.new", $cfile;
+
+    open(PLFILE, ">$plfile") or die "Can't create $plfile: $!\n";
+    print PLFILE "BEGIN { \$JPL::_env_ ||= 1; }	# suppress bogus embedding\n\n";
+    if (%classseen) {
+	my @classes = sort keys %classseen;
+	print PLFILE "use JPL::Class qw(@classes);\n\n";
+    }
+    print PLFILE $PERL;
+    print PLFILE "1;\n";
+    close PLFILE;
+
+    print "perl -c $plfile\n";
+    system "perl -c $plfile" and die "jpl stopped\n";
+}
+
+sub emit_c_header {
+    open(CFILE, ">$cfile.new") or die "Can't create $cfile.new: $!\n";
+    emit <<"";
+!/* This file is automatically generated.  Do not modify! */
+!
+!#include "$hfile"
+! 
+!#include "EXTERN.h"
+!#include "perl.h"
+! 
+!#ifndef EXTERN_C
+!#  ifdef __cplusplus
+!#    define EXTERN_C extern "C"
+!#  else
+!#    define EXTERN_C extern
+!#  endif
+!#endif
+!
+!extern int jpldebug;
+!extern JNIEnv* jplcurenv;
+!
+
+}
+
+
+sub emit_c_footer {
+    close CFILE;
+}
+
+sub emit {
+    my $string = shift;
+    $string =~ s/^!//mg;
+    print CFILE $string;
+}
+
+sub j2p_class {
+    my $jclass = shift;
+    $jclass =~ s#/#::#g;
+    $jclass;
+}
diff --git a/jpl/JPL/Makefile.PL b/jpl/JPL/Makefile.PL
new file mode 100644
index 0000000000..efb606da17
--- /dev/null
+++ b/jpl/JPL/Makefile.PL
@@ -0,0 +1,36 @@
+#!/usr/bin/perl
+
+$JPL_SRC = "..";
+
+use Config;
+
+eval `$JPL_SRC/setvars -perl`;
+
+open(MAKEFILE, ">Makefile");
+
+print MAKEFILE <<"SUBS";
+PERL = perl$]
+ARCHNAME = $Config{archname}
+JAVA_HOME = $ENV{JAVA_HOME}
+JPL_HOME = $ENV{JPL_HOME}
+PERLARCHDIR = $Config{archlib}
+
+SUBS
+
+print MAKEFILE <<'NOSUBS';
+
+all:
+
+debug:
+
+test:
+
+install:
+	mkdir -p $(JPL_HOME)/perl/JPL
+	cp *.p[ml] $(JPL_HOME)/perl/JPL
+
+clean:
+
+NOSUBS
+
+close MAKEFILE;