Commit | Line | Data |
d50cb536 |
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 | \*\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*\((.*?)\) |
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 |
377 | ! |
378 | |
379 | } |
380 | |
381 | emit <<""; |
57dea26d |
382 | ! if (SvTRUE(ERRSV)) { |
d50cb536 |
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 |
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 |
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 |
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 |
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 |
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 |
737 | !#include "EXTERN.h" |
738 | !#include "perl.h" |
739 | ! |
57dea26d |
740 | !#ifndef EXTERN_C |
741 | !# ifdef __cplusplus |
742 | !# define EXTERN_C extern "C" |
743 | !# else |
744 | !# define EXTERN_C extern |
745 | !# endif |
d50cb536 |
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 | } |