home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / jpl / JPL / Compile.pm < prev    next >
Text File  |  1999-09-14  |  17KB  |  770 lines
  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. }
  770.