| 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))
|
|---|
| 374 | ! retsv = *PL_stack_sp--;
|
|---|
| 375 | ! else
|
|---|
| 376 | ! retsv = &PL_sv_undef;
|
|---|
| 377 | !
|
|---|
| 378 |
|
|---|
| 379 | }
|
|---|
| 380 |
|
|---|
| 381 | emit <<"";
|
|---|
| 382 | ! if (SvTRUE(ERRSV)) {
|
|---|
| 383 | ! jthrowable newExcCls;
|
|---|
| 384 | !
|
|---|
| 385 | ! (*env)->ExceptionDescribe(env);
|
|---|
| 386 | ! (*env)->ExceptionClear(env);
|
|---|
| 387 | !
|
|---|
| 388 | ! newExcCls = (*env)->FindClass(env, "java/lang/RuntimeException");
|
|---|
| 389 | ! if (newExcCls)
|
|---|
| 390 | ! (*env)->ThrowNew(env, newExcCls, SvPV(ERRSV,PL_na));
|
|---|
| 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 <<"";
|
|---|
| 419 | ! retval = (*env)->NewStringUTF(env, SvPV(retsv,PL_na));
|
|---|
| 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);
|
|---|
| 471 | ! (*env)->Set${ptype}ArrayRegion(env, ja, 0, len, ($ntype*)SvPV(retsv,PL_na));
|
|---|
| 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++) {
|
|---|
| 498 | ! jobject str = (jobject)(*env)->NewStringUTF(env, SvPV(*esv,PL_na));
|
|---|
| 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,
|
|---|
| 538 | ! SvPV(*esv,PL_na));
|
|---|
| 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 | !
|
|---|
| 737 | !#include "EXTERN.h"
|
|---|
| 738 | !#include "perl.h"
|
|---|
| 739 | !
|
|---|
| 740 | !#ifndef EXTERN_C
|
|---|
| 741 | !# ifdef __cplusplus
|
|---|
| 742 | !# define EXTERN_C extern "C"
|
|---|
| 743 | !# else
|
|---|
| 744 | !# define EXTERN_C extern
|
|---|
| 745 | !# endif
|
|---|
| 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 | }
|
|---|
