3 # Copyright 1997, O'Reilly & Associate, Inc.
5 # This package may be copied under the same terms as Perl itself.
10 @EXPORT = qw(files file);
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])/;
35 my $DEBUG = $ENV{JPLDEBUG};
48 $ENV{CLASSPATH} =~ s/^/.:/ unless $ENV{CLASSPATH} =~ /^\.(?::|$)/;
54 #######################################################################
57 foreach my $jpfile (@_) {
73 (my $file = $jpfile) =~ s/\.jpl$//;
74 $jpfile = "$file.jpl";
75 $jfile = "$file.java";
79 $classfile = "$file.class";
81 ($h_file = $hfile) =~ s/_/_0005f/g;
85 # Extract out arg names from .java file, since .class doesn't have 'em.
87 open(JPFILE, $jpfile) or die "Can't open $jpfile: $!\n";
92 die "$jpfile doesn't seem to define class $file!\n"
93 unless /class\s+\b$file\b[\w\s.,]*{/;
96 open(JFILE, ">$jfile") or die "Can't create $jfile: $!\n";
98 while (m/\bperl\b([^\n]*?\b(\w+)\s*\(\s*(.*?)\s*\)[\s\w.,]*)\{\{(.*?)\}\}/sg) {
99 $JAVA = substr($`, $lastpos);
109 (my $repl = $4) =~ tr/\n//cd;
111 $linenum += $JAVA =~ tr/\n/\n/;
116 $perl =~ s/^[ \t]+\Z//m;
117 $perl =~ s/^[ \t]*\n//;
118 push(@protos, [$method, $proto, $perl, $linenum]);
120 $linenum += $repl =~ tr/\n/\n/;
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 \$@;");
133 print JFILE substr($_, $lastpos);
137 # Produce the corresponding .h file. Should really use make...
139 if (not -s $hfile or -M $hfile > -M $jfile) {
140 if (not -s $classfile or -M $classfile > -M $jfile) {
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!";
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;
154 if (not -s $hfile or -M $hfile > -M $jfile) {
155 die "Couldn't produce $hfile from $classfile!";
159 # Easiest place to get fields is from javap.
161 print "javap -s $file\n";
162 open(JP, "javap -s $file|");
165 if (/^\s+([A-Za-z_].*) (\w+)[\[\d\]]*;/) {
171 print "Field $jtype $name $_\n" if $DEBUG;
172 $fieldsig{$name} = $_;
173 $staticfield{$name} = $jtype =~ /\bstatic\b/;
175 while (m/L([^;]*);/g) {
176 my $pclass = j2p_class($1);
177 $classseen{$pclass}++;
182 open(HFILE, $hfile) or die "Couldn't open $hfile: $!\n";
187 die "panic: native method mismatch" if @protos != s/^JNIEXPORT/JNIEXPORT/gm;
191 \*\s*Class:\s*(\w+)\s*
192 \*\s*Method:\s*(\w+)\s*
193 \*\s*Signature:\s*(\S+)\s*\*/\s*
194 JNIEXPORT\s*(.*?)\s*JNICALL\s*(\w+)\s*\((.*?)\)
202 $class =~ s/_0005f/_/g;
203 if ($method ne $protos[$PROTO][0]) {
204 die "Method name mismatch: $method vs $protos[$PROTO][0]\n";
206 print "$class.$method($protos[$PROTO][1]) =>
208 $rettype $cname($ctypes)\n" if $DEBUG;
210 # Insert argument names into parameter list.
214 my @jargs = split(/\s*,\s*/, $protos[$PROTO][1]);
215 foreach my $arg (@jargs) {
216 $arg =~ s/^.*\b(\w+).*$/${1}/;
218 my @tmpargs = @jargs;
219 unshift(@tmpargs, $env, $obj);
220 print "\t@tmpargs\n" if $DEBUG;
222 $ctypes =~ s/,/' ' . shift(@tmpargs) . '_,'/eg;
224 $ctypes =~ s/env_/env/;
225 $ctypes =~ s/obj_/obj/;
226 print "\t$ctypes\n" if $DEBUG;
228 my $jlen = @jargs + 1;
230 (my $mangclass = $class) =~ s/_/_1/g;
231 (my $mangmethod = $method) =~ s/_/_1/g;
233 $plname =~ s/^Java_${mangclass}_${mangmethod}/JPL::${class}::${method}/;
234 $plname =~ s/Ljava_lang_String_2/s/g;
236 # Make glue code for each argument.
238 (my $sig = $signature) =~ s/^\(//;
243 foreach my $jarg (@jargs) {
244 if ($sig =~ s/^[ZBCSI]//) {
247 ! PUSHs(sv_2mortal(newSViv(${jarg}_)));
251 elsif ($sig =~ s/^[JFD]//) {
254 ! PUSHs(sv_2mortal(newSVnv(${jarg}_)));
258 elsif ($sig =~ s#^Ljava/lang/String;##) {
261 ! tmpjb = (jbyte*)(*env)->GetStringUTFChars(env,${jarg}_,0);
262 ! PUSHs(sv_2mortal(newSVpv((char*)tmpjb,0)));
263 ! (*env)->ReleaseStringUTFChars(env,${jarg}_,tmpjb);
267 elsif ($sig =~ s/^L([^;]*);//) {
268 my $pclass = j2p_class($1);
269 $classseen{$pclass}++;
272 ! if (!${jarg}_stashhv_)
273 ! ${jarg}_stashhv_ = gv_stashpv("$pclass", TRUE);
276 ! sv_setref_iv(sv_newmortal(), Nullch, (IV)(void*)${jarg}_),
277 ! ${jarg}_stashhv_));
279 ! fprintf(stderr, "Done with $jarg\\n");
283 ! static HV* ${jarg}_stashhv_ = 0;
287 elsif ($sig =~ s/^\[+([ZBCSIJFD]|L[^;]*;)//) {
288 my $pclass = "jarray";
289 $classseen{$pclass}++;
292 ! if (!${jarg}_stashhv_)
293 ! ${jarg}_stashhv_ = gv_stashpv("$pclass", TRUE);
296 ! sv_setref_iv(sv_newmortal(), Nullch, (IV)(void*)${jarg}_),
297 ! ${jarg}_stashhv_));
299 ! fprintf(stderr, "Done with $jarg\\n");
303 ! static HV* ${jarg}_stashhv_ = 0;
307 die "Short signature: $signature\n" if $sig eq "";
308 die "Unrecognized letter '" . substr($sig, 0, 1) . "' in signature $signature\n";
312 $sig =~ s/^\)// or die "Argument mismatch in signature: $method$signature\n";
314 my $void = $signature =~ /\)V$/;
316 $decls .= <<"" if $signature =~ m#java/lang/String#;
319 $decls .= <<"" unless $void;
324 ! fprintf(stderr, "Got to $cname\\n");
329 !JNIEXPORT $rettype JNICALL
332 ! static SV* methodsv = 0;
333 ! static HV* stashhv = 0;
339 ! sv_setiv(perl_get_sv("JPL::_env_", 1), (IV)(void*)env);
343 ! fprintf(stderr, "env = %lx\\n", (long)$env);
346 ! methodsv = (SV*)perl_get_cv("$plname", TRUE);
348 ! stashhv = gv_stashpv("JPL::$class", TRUE);
351 ! fprintf(stderr, "blessing obj = %lx\\n", obj);
353 ! sv_setref_iv(sv_newmortal(), Nullch, (IV)(void*)obj),
358 # Finally, call the subroutine.
361 $mod = "|G_DISCARD" if $void;
366 ! perl_call_sv(methodsv, G_EVAL|G_KEEPERR|G_DISCARD);
373 ! if (perl_call_sv(methodsv, G_EVAL|G_KEEPERR))
374 ! retsv = *PL_stack_sp--;
376 ! retsv = &PL_sv_undef;
382 ! if (SvTRUE(ERRSV)) {
383 ! jthrowable newExcCls;
385 ! (*env)->ExceptionDescribe(env);
386 ! (*env)->ExceptionClear(env);
388 ! newExcCls = (*env)->FindClass(env, "java/lang/RuntimeException");
390 ! (*env)->ThrowNew(env, newExcCls, SvPV(ERRSV,PL_na));
394 # Fix up the return value, if any.
396 if ($sig =~ s/^V//) {
401 elsif ($sig =~ s/^[ZBCSI]//) {
403 ! retval = ($rettype)SvIV(retsv);
409 elsif ($sig =~ s/^[JFD]//) {
411 ! retval = ($rettype)SvNV(retsv);
417 elsif ($sig =~ s#^Ljava/lang/String;##) {
419 ! retval = (*env)->NewStringUTF(env, SvPV(retsv,PL_na));
425 elsif ($sig =~ s/^L[^;]*;//) {
427 ! if (SvROK(retsv)) {
428 ! SV* rv = (SV*)SvRV(retsv);
430 ! retval = ($rettype)(void*)SvIV(rv);
432 ! retval = ($rettype)(void*)0;
435 ! retval = ($rettype)(void*)0;
441 elsif ($sig =~ s/^\[([ZBCSIJFD])//) {
443 my $ptype = "\u$ptype{$elemtype}";
444 my $ntype = "j$ptype{$elemtype}";
445 my $in = $elemtype =~ /^[JFD]/ ? "N" : "I";
447 ! if (SvROK(retsv)) {
448 ! SV* rv = (SV*)SvRV(retsv);
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));
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);
462 ! retval = ($rettype)ja;
465 ! retval = ($rettype)(void*)0;
467 ! else if (SvPOK(retsv)) {
468 ! jsize len = sv_len(retsv) / sizeof($ntype);
470 ! ${ntype}Array ja = (*env)->New${ptype}Array(env, len);
471 ! (*env)->Set${ptype}ArrayRegion(env, ja, 0, len, ($ntype*)SvPV(retsv,PL_na));
472 ! retval = ($rettype)ja;
475 ! retval = ($rettype)(void*)0;
481 elsif ($sig =~ s!^\[Ljava/lang/String;!!) {
483 ! if (SvROK(retsv)) {
484 ! SV* rv = (SV*)SvRV(retsv);
486 ! retval = ($rettype)(void*)SvIV(rv);
487 ! else if (SvTYPE(rv) == SVt_PVAV) {
488 ! jsize len = av_len((AV*)rv) + 1;
491 ! static jclass jcl = 0;
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++) {
498 ! jobject str = (jobject)(*env)->NewStringUTF(env, SvPV(*esv,PL_na));
499 ! (*env)->SetObjectArrayElement(env, ja, i, str);
501 ! retval = ($rettype)ja;
504 ! retval = ($rettype)(void*)0;
507 ! retval = ($rettype)(void*)0;
513 elsif ($sig =~ s/^(\[+)([ZBCSIJFD]|L[^;]*;)//) {
514 my $arity = length $1;
517 ! if (SvROK(retsv)) {
518 ! SV* rv = (SV*)SvRV(retsv);
520 ! retval = ($rettype)(void*)SvIV(rv);
521 ! else if (SvTYPE(rv) == SVt_PVAV) {
522 ! jsize len = av_len((AV*)rv) + 1;
525 ! static jclass jcl = 0;
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));
537 ! jobject str = (jobject)(*env)->NewStringUTF(env,
539 ! (*env)->SetObjectArrayElement(env, ja, i, str);
542 ! retval = ($rettype)ja;
545 ! retval = ($rettype)(void*)0;
548 ! retval = ($rettype)(void*)0;
555 die "No return type: $signature\n" if $sig eq "";
556 die "Unrecognized return type '" . substr($sig, 0, 1) . "' in signature $signature\n";
565 if ($class ne $LASTCLASS) {
568 package JPL::${class};
572 \$clazz = JNI::FindClass("$file");\n
574 foreach my $field (sort keys %fieldsig) {
575 my $sig = $fieldsig{$field};
576 my $ptype = $ptype{$sig};
579 if ($staticfield{$field}) {
581 \$${field}_FieldID = JNI::GetStaticFieldID(\$clazz, "$field", "$sig");
585 JNI::SetStatic${ptype}Field(\$clazz, \$${field}_FieldID, \$_[0]);
588 JNI::GetStatic${ptype}Field(\$clazz, \$${field}_FieldID);
595 \$${field}_FieldID = JNI::GetFieldID(\$clazz, "$field", "$sig");
599 JNI::Set${ptype}Field(\$self, \$${field}_FieldID, \$_[0]);
602 JNI::Get${ptype}Field(\$self, \$${field}_FieldID);
610 if ($pltype =~ s/^L(.*);/$1/) {
616 if ($pltype eq "java::lang::String") {
617 if ($staticfield{$field}) {
619 \$${field}_FieldID = JNI::GetStaticFieldID(\$clazz, "$field", "$sig");
623 JNI::SetStaticObjectField(\$clazz, \$${field}_FieldID,
624 ref \$_[0] ? \$_[0] : JNI::NewStringUTF(\$_[0]));
627 JNI::GetStringUTFChars(JNI::GetStaticObjectField(\$clazz, \$${field}_FieldID));
634 \$${field}_FieldID = JNI::GetFieldID(\$clazz, "$field", "$sig");
638 JNI::SetObjectField(\$self, \$${field}_FieldID,
639 ref \$_[0] ? \$_[0] : JNI::NewStringUTF(\$_[0]));
642 JNI::GetStringUTFChars(JNI::GetObjectField(\$self, \$${field}_FieldID));
649 if ($staticfield{$field}) {
651 \$${field}_FieldID = JNI::GetStaticFieldID(\$clazz, "$field", "$sig");
655 JNI::SetStaticObjectField(\$clazz, \$${field}_FieldID, \$_[0]);
658 bless JNI::GetStaticObjectField(\$clazz, \$${field}_FieldID), "$pltype";
665 \$${field}_FieldID = JNI::GetFieldID(\$clazz, "$field", "$sig");
669 JNI::SetObjectField(\$self, \$${field}_FieldID, \$_[0]);
672 bless JNI::GetObjectField(\$self, \$${field}_FieldID), "$pltype";
682 $plname =~ s/^JPL::${class}:://;
684 my $proto = '$' x (@jargs + 1);
685 $perl .= "sub $plname ($proto) {\n";
686 $perl .= ' my ($self, ';
687 foreach my $jarg (@jargs) {
688 $perl .= "\$$jarg, ";
690 $perl =~ s/, $/) = \@_;\n/;
692 warn "JPL::${class}::$plname(\@_)\\n" if \$JPL::DEBUG;
693 #line $protos[$PROTO][3] "$jpfile"
698 $PERLLINE += $perl =~ tr/\n/\n/ + 2;
708 print "\n" if $DEBUG;
713 rename $cfile, "$cfile.old";
714 rename "$cfile.new", $cfile;
716 open(PLFILE, ">$plfile") or die "Can't create $plfile: $!\n";
717 print PLFILE "BEGIN { \$JPL::_env_ ||= 1; } # suppress bogus embedding\n\n";
719 my @classes = sort keys %classseen;
720 print PLFILE "use JPL::Class qw(@classes);\n\n";
726 print "perl -c $plfile\n";
727 system "perl -c $plfile" and die "jpl stopped\n";
731 open(CFILE, ">$cfile.new") or die "Can't create $cfile.new: $!\n";
733 !/* This file is automatically generated. Do not modify! */
742 !# define EXTERN_C extern "C"
744 !# define EXTERN_C extern
748 !extern int jpldebug;
749 !extern JNIEnv* jplcurenv;