compile.pm

UNIX下perl实现代码

!	(*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;
}