use
vars
qw(@ISA @EXPORT $AUTOLOAD)
;
@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'
,
);
my
%type_table
= (
'void'
=>
'V'
,
'boolean'
=>
'Z'
,
'byte'
=>
'B'
,
'char'
=>
'C'
,
'short'
=>
'S'
,
'int'
=>
'I'
,
'long'
=>
'J'
,
'float'
=>
'F'
,
'double'
=>
'D'
);
my
%MID_CACHE
;
my
%METHOD_CACHE
;
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"
;
my
(
$methodname
,
$sig
,
$retsig
,
$slow_way
);
if
(
ref
$_
[1] eq
'ARRAY'
&&
ref
$_
[2] eq
'ARRAY'
) {
$slow_way
= 1;
my
(
$in
,
$out
) =
splice
(
@_
, 1, 2);
my
@in
= jni_mangle(
$in
);
unless
(@{
$out
}) {
$out
= [
'void'
];
}
my
@out
= jni_mangle(
$out
);
$methodname
=
$methodsig
;
$retsig
=
join
(
""
,
@out
);
$sig
=
"("
.
join
(
""
,
@in
) .
")"
.
$retsig
;
}
else
{
(
$methodname
,
$sig
) =
split
/__/,
$methodsig
, 2;
$sig
||=
"__V"
;
$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
{
$sig
=
"($sig)V"
;
$retsig
=
"V"
;
}
$sig
=~ s/_1/_/g;
}
print
"sig = $sig\n"
if
$JPL::DEBUG
;
$methodname
=
"<init>"
if
$methodname
eq
'new'
;
my
$mid
;
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>'
) {
$mid
= JNI::GetMethodID(
$class
,
$methodname
,
$sig
);
}
else
{
$mid
= JNI::GetStaticMethodID(
$class
,
$methodname
,
$sig
);
}
$MID_CACHE
{
qq[$classname:$methodname:$sig]
} =
$mid
if
$slow_way
;
if
(
$mid
== 0) {
JNI::ExceptionClear();
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
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
=~ /java::/) {
eval
<<"END" . <<'ENDQ';
package $blesspack;
END
'""'
=>
sub
{ JNI::GetStringUTFChars(
$_
[0]) },
'0+'
=>
sub
{ 0 +
"$_[0]"
},
fallback
=> 1;
ENDQ
}
else
{
eval
<<"END";
package $blesspack;
use JPL::AutoLoader;
END
}
}
}
my
$METHOD
;
my
$real_mid
=
$mid
+ 0;
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
;
$ret
=
'['
x
$arg
=~ s/\[\]//g;
if
(
$type_table
{
$arg
}) {
$ret
.=
$type_table
{
$arg
};
}
else
{
$arg
=~ s
$ret
.=
"L$arg;"
;
}
push
@ret
,
$ret
;
}
return
@ret
;
}
sub
getmeth {
my
(
$meth
,
$in
,
$out
) =
@_
;
my
@in
= jni_mangle(
$in
);
unless
(
$out
and
@$out
) {
$out
= [
'void'
];
}
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/
$meth
.
$sig
;
}
{
'""'
=>
sub
{ JNI::GetStringUTFChars(
$_
[0]) },
'0+'
=>
sub
{ 0 +
"$_[0]"
},
fallback
=> 1;
}
1;