jpl/JPL/Compile.pm

   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 }