dslinux/user/perl/jpl/JPL AutoLoader.pm Class.pm Compile.pm Makefile.PL
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:00:00 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/jpl/JPL
In directory antilope:/tmp/cvs-serv17422/jpl/JPL
Added Files:
AutoLoader.pm Class.pm Compile.pm Makefile.PL
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: AutoLoader.pm ---
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;
--- NEW FILE: Class.pm ---
package JPL::Class;
use JPL::AutoLoader ();
sub DESTROY {}
sub import {
my $class = shift;
foreach $class (@_) {
*{$class . "::AUTOLOAD"} = *JPL::AutoLoader::AUTOLOAD;
*{$class . "::DESTROY"} = \&DESTROY;
}
}
1;
--- NEW FILE: 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 at 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;
}
--- NEW FILE: Makefile.PL ---
use ExtUtils::MakeMaker;
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
WriteMakefile(
'NAME' => 'JPL::Class',
);
More information about the dslinux-commit
mailing list