[perl5.git] / JPL / Compile.pm

#!/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;
}
Commit	Line	Data
d50cb536 GS	1	#!/usr/bin/perl -w
	2
	3	# Copyright 1997, O'Reilly & Associate, Inc.
	4	#
	5	# This package may be copied under the same terms as Perl itself.
	6
	7	package JPL::Compile;
	8	use Exporter ();
	9	@ISA = qw(Exporter);
	10	@EXPORT = qw(files file);
	11
	12	use strict;
	13
	14
	15	warn "You don't have a recent JDK kit your PATH, so this may fail.\n"
	16	unless $ENV{PATH} =~ /(java\|jdk1.[1-9])/;
	17
	18	sub emit;
	19
	20	my $PERL = "";
	21	my $LASTCLASS = "";
	22	my $PERLLINE = 0;
	23	my $PROTO;
	24
	25	my @protos;
	26
	27	my $plfile;
	28	my $jpfile;
	29	my $hfile;
	30	my $h_file;
	31	my $cfile;
	32	my $jfile;
	33	my $classfile;
	34
	35	my $DEBUG = $ENV{JPLDEBUG};
	36
	37	my %ptype = qw(
	38	Z boolean
	39	B byte
	40	C char
	41	S short
	42	I int
	43	J long
	44	F float
	45	D double
	46	);
	47
	48	$ENV{CLASSPATH} =~ s/^/.:/ unless $ENV{CLASSPATH} =~ /^\.(?::\|$)/;
	49
	50	unless (caller) {
	51	files(@ARGV);
	52	}
	53
	54	#######################################################################
	55
	56	sub files {
	57	foreach my $jpfile (@_) {
	58	file($jpfile);
	59	}
	60	print "make\n";
	61	system "make";
	62	}
	63
	64	sub file {
65	my $jpfile = shift;
66	my $JAVA = "";
67	my $lastpos = 0;
68	my $linenum = 2;
69	my %classseen;
70	my %fieldsig;
71	my %staticfield;
72
73	(my $file = $jpfile) =~ s/\.jpl$//;
74	$jpfile = "$file.jpl";
75	$jfile = "$file.java";
76	$hfile = "$file.h";
77	$cfile = "$file.c";
78	$plfile = "$file.pl";
79	$classfile = "$file.class";
80
81	($h_file = $hfile) =~ s/_/_0005f/g;
82
83	emit_c_header();
84
85	# Extract out arg names from .java file, since .class doesn't have 'em.
86
87	open(JPFILE, $jpfile) or die "Can't open $jpfile: $!\n";
88	undef $/;
89	$_ = <JPFILE>;
90	close JPFILE;
91
92	die "$jpfile doesn't seem to define class $file!\n"
93	unless /class\s+\b$file\b[\w\s.,]*{/;
94
95	@protos = ();
96	open(JFILE, ">$jfile") or die "Can't create $jfile: $!\n";
97
98	while (m/\bperl\b([^\n]?\b(\w+)\s\(\s(.?)\s\)[\s\w.,])\{\{(.*?)\}\}/sg) {
99	$JAVA = substr($`, $lastpos);
100	$lastpos = pos $_;
101	$JAVA .= "native";
102	$JAVA .= $1;
103
104	my $method = $2;
105
106	my $proto = $3;
107
108	my $perl = $4;
109	(my $repl = $4) =~ tr/\n//cd;
110	$JAVA .= ';';
111	$linenum += $JAVA =~ tr/\n/\n/;
112	$JAVA .= $repl;
113	print JFILE $JAVA;
114
115	$proto =~ s/\s+/ /g;
116	$perl =~ s/^[ \t]+\Z//m;
117	$perl =~ s/^[ \t]*\n//;
118	push(@protos, [$method, $proto, $perl, $linenum]);
119
120	$linenum += $repl =~ tr/\n/\n/;
121	}
122
123	print JFILE <<"END";
124	static {
125	System.loadLibrary("$file");
126	PerlInterpreter pi = new PerlInterpreter().fetch();
127	// pi.eval("\$JPL::DEBUG = \$ENV{JPLDEBUG};");
128	pi.eval("warn qq{loading $file\\n} if \$JPL::DEBUG");
129	pi.eval("eval {require '$plfile'}; print \$@ if \$@;");
130	}
131	END
132
133	print JFILE substr($_, $lastpos);
134
135	close JFILE;
136
137	# Produce the corresponding .h file. Should really use make...
138
139	if (not -s $hfile or -M $hfile > -M $jfile) {
140	if (not -s $classfile or -M $classfile > -M $jfile) {
141	unlink $classfile;
142	print "javac $jfile\n";
143	system "javac $jfile" and die "Couldn't run javac: exit $?\n";
144	if (not -s $classfile or -M $classfile > -M $jfile) {
145	die "Couldn't produce $classfile from $jfile!";
146	}
147	}
148	unlink $hfile;
149	print "javah -jni $file\n";
150	system "javah -jni $file" and die "Couldn't run javah: exit $?\n";
151	if (not -s $hfile and -s $h_file) {
152	rename $h_file, $hfile;
153	}
154	if (not -s $hfile or -M $hfile > -M $jfile) {
155	die "Couldn't produce $hfile from $classfile!";
156	}
157	}
158
159	# Easiest place to get fields is from javap.
160
161	print "javap -s $file\n";
162	open(JP, "javap -s $file\|");
163	$/ = "\n";
164	while (<JP>) {
165	if (/^\s+([A-Za-z_].) (\w+)[\[\d\]];/) {
166	my $jtype = $1;
167	my $name = $2;
168	$_ = <JP>;
169	s!^\s/\\s*!!;
170	s!\s\/\s*!!;
171	print "Field $jtype $name $_\n" if $DEBUG;
172	$fieldsig{$name} = $_;
173	$staticfield{$name} = $jtype =~ /\bstatic\b/;
174	}
175	while (m/L([^;]*);/g) {
176	my $pclass = j2p_class($1);
177	$classseen{$pclass}++;
178	}
179	}
180	close JP;
181
182	open(HFILE, $hfile) or die "Couldn't open $hfile: $!\n";
183	undef $/;
184	$_ = <HFILE>;
185	close HFILE;
186
187	die "panic: native method mismatch" if @protos != s/^JNIEXPORT/JNIEXPORT/gm;
188
189	$PROTO = 0;
190	while (m{
191	\\sClass:\s(\w+)\s
192	\\sMethod:\s(\w+)\s
193	\\sSignature:\s(\S+)\s\/\s
194	JNIEXPORT\s(.?)\sJNICALL\s(\w+)\s\((.?)\)
195	}gx) {
196	my $class = $1;
197	my $method = $2;
198	my $signature = $3;
199	my $rettype = $4;
200	my $cname = $5;
201	my $ctypes = $6;
202	$class =~ s/_0005f/_/g;
203	if ($method ne $protos[$PROTO][0]) {
204	die "Method name mismatch: $method vs $protos[$PROTO][0]\n";
205	}
206	print "$class.$method($protos[$PROTO][1]) =>
207	$signature
208	$rettype $cname($ctypes)\n" if $DEBUG;
209
210	# Insert argument names into parameter list.
211
212	my $env = "env";
213	my $obj = "obj";
214	my @jargs = split(/\s,\s/, $protos[$PROTO][1]);
215	foreach my $arg (@jargs) {
216	$arg =~ s/^.\b(\w+).$/${1}/;
217	}
218	my @tmpargs = @jargs;
219	unshift(@tmpargs, $env, $obj);
220	print "\t@tmpargs\n" if $DEBUG;
221	$ctypes .= ",";
222	$ctypes =~ s/,/' ' . shift(@tmpargs) . '_,'/eg;
223	$ctypes =~ s/,$//;
224	$ctypes =~ s/env_/env/;
225	$ctypes =~ s/obj_/obj/;
226	print "\t$ctypes\n" if $DEBUG;
227
228	my $jlen = @jargs + 1;
229
230	(my $mangclass = $class) =~ s/_/_1/g;
231	(my $mangmethod = $method) =~ s/_/_1/g;
232	my $plname = $cname;
233	$plname =~ s/^Java_${mangclass}_${mangmethod}/JPL::${class}::${method}/;
234	$plname =~ s/Ljava_lang_String_2/s/g;
235
236	# Make glue code for each argument.
237
238	(my $sig = $signature) =~ s/^\(//;
239
240	my $decls = "";
241	my $glue = "";
242
243	foreach my $jarg (@jargs) {
244	if ($sig =~ s/^[ZBCSI]//) {
245	$glue .= <<"";
246	! /* $jarg */
247	! PUSHs(sv_2mortal(newSViv(${jarg}_)));
248	!
249
250	}
251	elsif ($sig =~ s/^[JFD]//) {
252	$glue .= <<"";
253	! /* $jarg */
254	! PUSHs(sv_2mortal(newSVnv(${jarg}_)));
255	!
256
257	}
258	elsif ($sig =~ s#^Ljava/lang/String;##) {
259	$glue .= <<"";
260	! /* $jarg */
261	! tmpjb = (jbyte)(env)->GetStringUTFChars(env,${jarg}_,0);
262	! PUSHs(sv_2mortal(newSVpv((char*)tmpjb,0)));
263	! (*env)->ReleaseStringUTFChars(env,${jarg}_,tmpjb);
264	!
265
266	}
267	elsif ($sig =~ s/^L([^;]*);//) {
268	my $pclass = j2p_class($1);
269	$classseen{$pclass}++;
270	$glue .= <<"";
271	! /* $jarg */
272	! if (!${jarg}_stashhv_)
273	! ${jarg}_stashhv_ = gv_stashpv("$pclass", TRUE);
274	!
275	! PUSHs(sv_bless(
276	! sv_setref_iv(sv_newmortal(), Nullch, (IV)(void*)${jarg}_),
277	! ${jarg}_stashhv_));
278	! if (jpldebug)
279	! fprintf(stderr, "Done with $jarg\\n");
280	!
281
282	$decls .= <<"";
283	! static HV* ${jarg}_stashhv_ = 0;
284
285
286	}
287	elsif ($sig =~ s/^\[+([ZBCSIJFD]\|L[^;]*;)//) {
288	my $pclass = "jarray";
289	$classseen{$pclass}++;
290	$glue .= <<"";
291	! /* $jarg */
292	! if (!${jarg}_stashhv_)
293	! ${jarg}_stashhv_ = gv_stashpv("$pclass", TRUE);
294	!
295	! PUSHs(sv_bless(
296	! sv_setref_iv(sv_newmortal(), Nullch, (IV)(void*)${jarg}_),
297	! ${jarg}_stashhv_));
298	! if (jpldebug)
299	! fprintf(stderr, "Done with $jarg\\n");
300	!
301
302	$decls .= <<"";
303	! static HV* ${jarg}_stashhv_ = 0;
304
305	}
306	else {
307	die "Short signature: $signature\n" if $sig eq "";
308	die "Unrecognized letter '" . substr($sig, 0, 1) . "' in signature $signature\n";
309	}
310	}
311
312	$sig =~ s/^\)// or die "Argument mismatch in signature: $method$signature\n";
313
314	my $void = $signature =~ /\)V$/;
315
316	$decls .= <<"" if $signature =~ m#java/lang/String#;
317	! jbyte* tmpjb;
318
319	$decls .= <<"" unless $void;
320	! SV* retsv;
321	! $rettype retval;
322	!
323	! if (jpldebug)
324	! fprintf(stderr, "Got to $cname\\n");
325	! ENTER;
326	! SAVETMPS;
327
328	emit <<"";
329	!JNIEXPORT $rettype JNICALL
330	!$cname($ctypes)
331	!{
332	! static SV* methodsv = 0;
333	! static HV* stashhv = 0;
334	! dSP;
335	$decls
336	! PUSHMARK(sp);
337	! EXTEND(sp,$jlen);
338	!
339	! sv_setiv(perl_get_sv("JPL::_env_", 1), (IV)(void*)env);
340	! jplcurenv = env;
341	!
342	! if (jpldebug)
343	! fprintf(stderr, "env = %lx\\n", (long)$env);
344	!
345	! if (!methodsv)
346	! methodsv = (SV*)perl_get_cv("$plname", TRUE);
347	! if (!stashhv)
348	! stashhv = gv_stashpv("JPL::$class", TRUE);
349	!
350	! if (jpldebug)
351	! fprintf(stderr, "blessing obj = %lx\\n", obj);
352	! PUSHs(sv_bless(
353	! sv_setref_iv(sv_newmortal(), Nullch, (IV)(void*)obj),
354	! stashhv));
355	!
356	$glue
357
358	# Finally, call the subroutine.
359
360	my $mod;
361	$mod = "\|G_DISCARD" if $void;
362
363	if ($void) {
364	emit <<"";
365	! PUTBACK;
366	! perl_call_sv(methodsv, G_EVAL\|G_KEEPERR\|G_DISCARD);
367	!
368
369	}
370	else {
371	emit <<"";
372	! PUTBACK;
373	! if (perl_call_sv(methodsv, G_EVAL\|G_KEEPERR))
57dea26d	374	! retsv = *PL_stack_sp--;
d50cb536	375	! else
57dea26d	376	! retsv = &PL_sv_undef;
d50cb536 GS	377	!
	378
	379	}
	380
	381	emit <<"";
57dea26d	382	! if (SvTRUE(ERRSV)) {
d50cb536 GS	383	! jthrowable newExcCls;
	384	!
	385	! (*env)->ExceptionDescribe(env);
	386	! (*env)->ExceptionClear(env);
	387	!
	388	! newExcCls = (*env)->FindClass(env, "java/lang/RuntimeException");
	389	! if (newExcCls)
57dea26d	390	! (*env)->ThrowNew(env, newExcCls, SvPV(ERRSV,PL_na));
d50cb536 GS	391	! }
	392	!
	393
	394	# Fix up the return value, if any.
	395
	396	if ($sig =~ s/^V//) {
	397	emit <<"";
	398	! return;
	399
	400	}
	401	elsif ($sig =~ s/^[ZBCSI]//) {
	402	emit <<"";
	403	! retval = ($rettype)SvIV(retsv);
	404	! FREETMPS;
	405	! LEAVE;
	406	! return retval;
	407
	408	}
	409	elsif ($sig =~ s/^[JFD]//) {
	410	emit <<"";
	411	! retval = ($rettype)SvNV(retsv);
	412	! FREETMPS;
	413	! LEAVE;
	414	! return retval;
	415
	416	}
	417	elsif ($sig =~ s#^Ljava/lang/String;##) {
	418	emit <<"";
57dea26d	419	! retval = (*env)->NewStringUTF(env, SvPV(retsv,PL_na));
d50cb536 GS	420	! FREETMPS;
	421	! LEAVE;
	422	! return retval;
	423
	424	}
	425	elsif ($sig =~ s/^L[^;]*;//) {
	426	emit <<"";
	427	! if (SvROK(retsv)) {
	428	! SV* rv = (SV*)SvRV(retsv);
	429	! if (SvOBJECT(rv))
	430	! retval = ($rettype)(void*)SvIV(rv);
	431	! else
	432	! retval = ($rettype)(void*)0;
	433	! }
	434	! else
	435	! retval = ($rettype)(void*)0;
	436	! FREETMPS;
	437	! LEAVE;
	438	! return retval;
	439
	440	}
	441	elsif ($sig =~ s/^\[([ZBCSIJFD])//) {
	442	my $elemtype = $1;
	443	my $ptype = "\u$ptype{$elemtype}";
	444	my $ntype = "j$ptype{$elemtype}";
	445	my $in = $elemtype =~ /^[JFD]/ ? "N" : "I";
	446	emit <<"";
	447	! if (SvROK(retsv)) {
	448	! SV* rv = (SV*)SvRV(retsv);
	449	! if (SvOBJECT(rv))
	450	! retval = ($rettype)(void*)SvIV(rv);
	451	! else if (SvTYPE(rv) == SVt_PVAV) {
	452	! jsize len = av_len((AV*)rv) + 1;
	453	! $ntype* buf = ($ntype)malloc(len sizeof($ntype));
	454	! int i;
	455	! SV** esv;
	456	!
	457	! ${ntype}Array ja = (*env)->New${ptype}Array(env, len);
	458	! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
	459	! buf[i] = ($ntype)Sv${in}V(*esv);
	460	! (*env)->Set${ptype}ArrayRegion(env, ja, 0, len, buf);
	461	! free((void*)buf);
	462	! retval = ($rettype)ja;
	463	! }
	464	! else
	465	! retval = ($rettype)(void*)0;
	466	! }
	467	! else if (SvPOK(retsv)) {
	468	! jsize len = sv_len(retsv) / sizeof($ntype);
	469	!
	470	! ${ntype}Array ja = (*env)->New${ptype}Array(env, len);
57dea26d	471	! (env)->Set${ptype}ArrayRegion(env, ja, 0, len, ($ntype)SvPV(retsv,PL_na));
d50cb536 GS	472	! retval = ($rettype)ja;
	473	! }
	474	! else
	475	! retval = ($rettype)(void*)0;
	476	! FREETMPS;
	477	! LEAVE;
	478	! return retval;
	479
	480	}
	481	elsif ($sig =~ s!^\[Ljava/lang/String;!!) {
	482	emit <<"";
	483	! if (SvROK(retsv)) {
	484	! SV* rv = (SV*)SvRV(retsv);
	485	! if (SvOBJECT(rv))
	486	! retval = ($rettype)(void*)SvIV(rv);
	487	! else if (SvTYPE(rv) == SVt_PVAV) {
	488	! jsize len = av_len((AV*)rv) + 1;
	489	! int i;
	490	! SV** esv;
	491	! static jclass jcl = 0;
	492	! jarray ja;
	493	!
	494	! if (!jcl)
	495	! jcl = (*env)->FindClass(env, "java/lang/String");
	496	! ja = (*env)->NewObjectArray(env, len, jcl, 0);
	497	! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) {
57dea26d	498	! jobject str = (jobject)(env)->NewStringUTF(env, SvPV(esv,PL_na));
d50cb536 GS	499	! (*env)->SetObjectArrayElement(env, ja, i, str);
	500	! }
	501	! retval = ($rettype)ja;
	502	! }
	503	! else
	504	! retval = ($rettype)(void*)0;
	505	! }
	506	! else
	507	! retval = ($rettype)(void*)0;
	508	! FREETMPS;
	509	! LEAVE;
	510	! return retval;
	511
	512	}
	513	elsif ($sig =~ s/^(\[+)([ZBCSIJFD]\|L[^;]*;)//) {
	514	my $arity = length $1;
	515	my $elemtype = $2;
	516	emit <<"";
	517	! if (SvROK(retsv)) {
	518	! SV* rv = (SV*)SvRV(retsv);
	519	! if (SvOBJECT(rv))
	520	! retval = ($rettype)(void*)SvIV(rv);
	521	! else if (SvTYPE(rv) == SVt_PVAV) {
	522	! jsize len = av_len((AV*)rv) + 1;
	523	! int i;
	524	! SV** esv;
	525	! static jclass jcl = 0;
	526	! jarray ja;
	527	!
	528	! if (!jcl)
	529	! jcl = (*env)->FindClass(env, "java/lang/Object");
	530	! ja = (*env)->NewObjectArray(env, len, jcl, 0);
	531	! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) {
	532	! if (SvROK(esv) && (rv = SvRV(esv)) && SvOBJECT(rv)) {
	533	! (*env)->SetObjectArrayElement(env, ja, i,
	534	! (jobject)(void*)SvIV(rv));
	535	! }
	536	! else {
	537	! jobject str = (jobject)(*env)->NewStringUTF(env,
57dea26d	538	! SvPV(*esv,PL_na));
d50cb536 GS	539	! (*env)->SetObjectArrayElement(env, ja, i, str);
	540	! }
	541	! }
	542	! retval = ($rettype)ja;
	543	! }
	544	! else
	545	! retval = ($rettype)(void*)0;
	546	! }
	547	! else
	548	! retval = ($rettype)(void*)0;
	549	! FREETMPS;
	550	! LEAVE;
	551	! return retval;
	552
	553	}
	554	else {
	555	die "No return type: $signature\n" if $sig eq "";
	556	die "Unrecognized return type '" . substr($sig, 0, 1) . "' in signature $signature\n";
	557	}
	558
	559	emit <<"";
	560	!}
	561	!
	562
	563	my $perl = "";
	564
	565	if ($class ne $LASTCLASS) {
	566	$LASTCLASS = $class;
	567	$perl .= <<"";
	568	package JPL::${class};
	569	use JNI;
	570	use JPL::AutoLoader;
	571	\@ISA = qw(jobject);
	572	\$clazz = JNI::FindClass("$file");\n
	573
	574	foreach my $field (sort keys %fieldsig) {
	575	my $sig = $fieldsig{$field};
	576	my $ptype = $ptype{$sig};
	577	if ($ptype) {
	578	$ptype = "\u$ptype";
	579	if ($staticfield{$field}) {
	580	$perl .= <<"";
	581	\$${field}_FieldID = JNI::GetStaticFieldID(\$clazz, "$field", "$sig");
	582	sub $field (\$;\$) {
	583	my \$self = shift;
	584	if (\@_) {
	585	JNI::SetStatic${ptype}Field(\$clazz, \$${field}_FieldID, \$_[0]);
	586	}
	587	else {
	588	JNI::GetStatic${ptype}Field(\$clazz, \$${field}_FieldID);
	589	}
	590	}\n
	591
	592	}
	593	else {
	594	$perl .= <<"";
	595	\$${field}_FieldID = JNI::GetFieldID(\$clazz, "$field", "$sig");
	596	sub $field (\$;\$) {
	597	my \$self = shift;
	598	if (\@_) {
	599	JNI::Set${ptype}Field(\$self, \$${field}_FieldID, \$_[0]);
	600	}
	601	else {
	602	JNI::Get${ptype}Field(\$self, \$${field}_FieldID);
603	}
604	}\n
605
606	}
607	}
608	else {
609	my $pltype = $sig;
610	if ($pltype =~ s/^L(.*);/$1/) {
611	$pltype =~ s!/!::!g;
612	}
613	else {
614	$pltype = 'jarray';
615	}
616	if ($pltype eq "java::lang::String") {
617	if ($staticfield{$field}) {
618	$perl .= <<"";
619	\$${field}_FieldID = JNI::GetStaticFieldID(\$clazz, "$field", "$sig");
620	sub $field (\$;\$) {
621	my \$self = shift;
622	if (\@_) {
623	JNI::SetStaticObjectField(\$clazz, \$${field}_FieldID,
624	ref \$_[0] ? \$_[0] : JNI::NewStringUTF(\$_[0]));
625	}
626	else {
627	JNI::GetStringUTFChars(JNI::GetStaticObjectField(\$clazz, \$${field}_FieldID));
628	}
629	}\n
630
631	}
632	else {
633	$perl .= <<"";
634	\$${field}_FieldID = JNI::GetFieldID(\$clazz, "$field", "$sig");
635	sub $field (\$;\$) {
636	my \$self = shift;
637	if (\@_) {
638	JNI::SetObjectField(\$self, \$${field}_FieldID,
639	ref \$_[0] ? \$_[0] : JNI::NewStringUTF(\$_[0]));
640	}
641	else {
642	JNI::GetStringUTFChars(JNI::GetObjectField(\$self, \$${field}_FieldID));
643	}
644	}\n
645
646	}
647	}
648	else {
649	if ($staticfield{$field}) {
650	$perl .= <<"";
651	\$${field}_FieldID = JNI::GetStaticFieldID(\$clazz, "$field", "$sig");
652	sub $field (\$;\$) {
653	my \$self = shift;
654	if (\@_) {
655	JNI::SetStaticObjectField(\$clazz, \$${field}_FieldID, \$_[0]);
656	}
657	else {
658	bless JNI::GetStaticObjectField(\$clazz, \$${field}_FieldID), "$pltype";
659	}
660	}\n
661
662	}
663	else {
664	$perl .= <<"";
665	\$${field}_FieldID = JNI::GetFieldID(\$clazz, "$field", "$sig");
666	sub $field (\$;\$) {
667	my \$self = shift;
668	if (\@_) {
669	JNI::SetObjectField(\$self, \$${field}_FieldID, \$_[0]);
670	}
671	else {
672	bless JNI::GetObjectField(\$self, \$${field}_FieldID), "$pltype";
673	}
674	}\n
675
676	}
677	}
678	}
679	}
680	}
681
682	$plname =~ s/^JPL::${class}:://;
683
684	my $proto = '$' x (@jargs + 1);
685	$perl .= "sub $plname ($proto) {\n";
686	$perl .= ' my ($self, ';
687	foreach my $jarg (@jargs) {
688	$perl .= "\$$jarg, ";
689	}
690	$perl =~ s/, $/) = \@_;\n/;
691	$perl .= <<"END";
692	warn "JPL::${class}::$plname(\@_)\\n" if \$JPL::DEBUG;
693	#line $protos[$PROTO][3] "$jpfile"
694	$protos[$PROTO][2]}
695
696	END
697
698	$PERLLINE += $perl =~ tr/\n/\n/ + 2;
699	$perl .= <<"END";
700	#line $PERLLINE ""
701	END
702	$PERLLINE--;
703
704	$PERL .= $perl;
705	}
706	continue {
707	$PROTO++;
708	print "\n" if $DEBUG;
709	}
710
711	emit_c_footer();
712
713	rename $cfile, "$cfile.old";
714	rename "$cfile.new", $cfile;
715
716	open(PLFILE, ">$plfile") or die "Can't create $plfile: $!\n";
717	print PLFILE "BEGIN { \$JPL::_env_ \|\|= 1; } # suppress bogus embedding\n\n";
718	if (%classseen) {
719	my @classes = sort keys %classseen;
720	print PLFILE "use JPL::Class qw(@classes);\n\n";
721	}
722	print PLFILE $PERL;
723	print PLFILE "1;\n";
724	close PLFILE;
725
726	print "perl -c $plfile\n";
727	system "perl -c $plfile" and die "jpl stopped\n";
728	}
729
730	sub emit_c_header {
731	open(CFILE, ">$cfile.new") or die "Can't create $cfile.new: $!\n";
732	emit <<"";
733	!/* This file is automatically generated. Do not modify! */
734	!
735	!#include "$hfile"
736	!
d50cb536 GS	737	!#include "EXTERN.h"
	738	!#include "perl.h"
	739	!
57dea26d GS	740	!#ifndef EXTERN_C
	741	!# ifdef __cplusplus
	742	!# define EXTERN_C extern "C"
	743	!# else
	744	!# define EXTERN_C extern
	745	!# endif
d50cb536 GS	746	!#endif
	747	!
	748	!extern int jpldebug;
	749	!extern JNIEnv* jplcurenv;
	750	!
	751
	752	}
	753
	754
	755	sub emit_c_footer {
	756	close CFILE;
	757	}
	758
	759	sub emit {
	760	my $string = shift;
	761	$string =~ s/^!//mg;
	762	print CFILE $string;
	763	}
	764
	765	sub j2p_class {
	766	my $jclass = shift;
	767	$jclass =~ s#/#::#g;
	768	$jclass;
	769	}