compile.pm

UNIX下perl实现代码

#!/usr/bin/perl -w

# Copyright 1997, O'Reilly & Associate, Inc.
#
# This package may be copied under the same terms as Perl itself.

package JPL::Compile;
use Exporter ();
@ISA = qw(Exporter);
@EXPORT = qw(files file);

use strict;


warn "You don't have a recent JDK kit your PATH, so this may fail.\n"
    unless $ENV{PATH} =~ /(java|jdk1.[1-9])/;

sub emit;

my $PERL = "";
my $LASTCLASS = "";
my $PERLLINE = 0;
my $PROTO;

my @protos;

my $plfile;
my $jpfile;
my $hfile;
my $h_file;
my $cfile;
my $jfile;
my $classfile;

my $DEBUG = $ENV{JPLDEBUG};

my %ptype = qw(
	Z boolean
	B byte
	C char
	S short
	I int
	J long
	F float
	D double
);

$ENV{CLASSPATH} =~ s/^/.:/ unless $ENV{CLASSPATH} =~ /^\.(?::|$)/;

unless (caller) {
    files(@ARGV);
}

#######################################################################

sub files {
    foreach my $jpfile (@_) {
	file($jpfile);
    }
    print "make\n";
    system "make";
}

sub file {
    my $jpfile = shift;
    my $JAVA = "";
    my $lastpos = 0;
    my $linenum = 2;
    my %classseen;
    my %fieldsig;
    my %staticfield;

    (my $file = $jpfile) =~ s/\.jpl$//;
    $jpfile = "$file.jpl";
    $jfile = "$file.java";
    $hfile = "$file.h";
    $cfile = "$file.c";
    $plfile = "$file.pl";
    $classfile = "$file.class";

    ($h_file = $hfile) =~ s/_/_0005f/g;

    emit_c_header();

    # Extract out arg names from .java file, since .class doesn't have 'em.

    open(JPFILE, $jpfile) or die "Can't open $jpfile: $!\n";
    undef $/;
    $_ = <JPFILE>;
    close JPFILE;

    die "$jpfile doesn't seem to define class $file!\n"
	unless /class\s+\b$file\b[\w\s.,]*{/;

    @protos = ();
    open(JFILE, ">$jfile") or die "Can't create $jfile: $!\n";

    while (m/\bperl\b([^\n]*?\b(\w+)\s*\(\s*(.*?)\s*\)[\s\w.,]*)\{\{(.*?)\}\}/sg) {
	$JAVA = substr($`, $lastpos);
	$lastpos = pos $_;
	$JAVA .= "native";
	$JAVA .= $1;

	my $method = $2;

	my $proto = $3;

	my $perl = $4;
	(my $repl = $4) =~ tr/\n//cd;
	$JAVA .= ';';
	$linenum += $JAVA =~ tr/\n/\n/;
	$JAVA .= $repl;
	print JFILE $JAVA;

	$proto =~ s/\s+/ /g;
	$perl =~ s/^[ \t]+\Z//m;
	$perl =~ s/^[ \t]*\n//;
	push(@protos, [$method, $proto, $perl, $linenum]);

	$linenum += $repl =~ tr/\n/\n/;
    }

    print JFILE <<"END";
    static {
	System.loadLibrary("$file");
        PerlInterpreter pi = new PerlInterpreter().fetch();
        // pi.eval("\$JPL::DEBUG = \$ENV{JPLDEBUG};");
	pi.eval("warn qq{loading $file\\n} if \$JPL::DEBUG");
	pi.eval("eval {require '$plfile'}; print \$@ if \$@;");
    }
END

    print JFILE substr($_, $lastpos);

    close JFILE;

    # Produce the corresponding .h file.  Should really use make...

    if (not -s $hfile or -M $hfile > -M $jfile) {
	if (not -s $classfile or -M $classfile > -M $jfile) {
	    unlink $classfile;
	    print  "javac $jfile\n";
	    system "javac $jfile" and die "Couldn't run javac: exit $?\n";
	    if (not -s $classfile or -M $classfile > -M $jfile) {
		die "Couldn't produce $classfile from $jfile!";
	    }
	}
	unlink $hfile;
	print  "javah -jni $file\n";
	system "javah -jni $file" and die "Couldn't run javah: exit $?\n";
	if (not -s $hfile and -s $h_file) {
	    rename $h_file, $hfile;
	}
	if (not -s $hfile or -M $hfile > -M $jfile) {
	    die "Couldn't produce $hfile from $classfile!";
	}
    }

    # Easiest place to get fields is from javap.

    print  "javap -s $file\n";
    open(JP, "javap -s $file|");
    $/ = "\n";
    while (<JP>) {
	if (/^\s+([A-Za-z_].*) (\w+)[\[\d\]]*;/) {
	    my $jtype = $1;
	    my $name = $2;
	    $_ = <JP>;
	    s!^\s*/\*\s*!!;
	    s!\s*\*/\s*!!;
	    print "Field $jtype $name $_\n" if $DEBUG;
	    $fieldsig{$name} = $_;
	    $staticfield{$name} = $jtype =~ /\bstatic\b/;
	}
	while (m/L([^;]*);/g) {
	    my $pclass = j2p_class($1);
	    $classseen{$pclass}++;
	}
    }
    close JP;

    open(HFILE, $hfile) or die "Couldn't open $hfile: $!\n";
    undef $/;
    $_ = <HFILE>;
    close HFILE;

    die "panic: native method mismatch" if @protos != s/^JNIEXPORT/JNIEXPORT/gm;

    $PROTO = 0;
    while (m{
	\*\s*Class:\s*(\w+)\s*
	\*\s*Method:\s*(\w+)\s*
	\*\s*Signature:\s*(\S+)\s*\*/\s*
	JNIEXPORT\s*(.*?)\s*JNICALL\s*(\w+)\s*\((.*?)\)
    }gx) {
	my $class = $1;
	my $method = $2;
	my $signature = $3;
	my $rettype = $4;
	my $cname = $5;
	my $ctypes = $6;
	$class =~ s/_0005f/_/g;
	if ($method ne $protos[$PROTO][0]) {
	    die "Method name mismatch: $method vs $protos[$PROTO][0]\n";
	}
	print "$class.$method($protos[$PROTO][1]) =>
	$signature
	$rettype $cname($ctypes)\n" if $DEBUG;

	# Insert argument names into parameter list.

	my $env = "env";
	my $obj = "obj";
	my @jargs = split(/\s*,\s*/, $protos[$PROTO][1]);
	foreach my $arg (@jargs) {
	    $arg =~ s/^.*\b(\w+).*$/${1}/;
	}
	my @tmpargs = @jargs;
	unshift(@tmpargs, $env, $obj);
	print "\t@tmpargs\n" if $DEBUG;
	$ctypes .= ",";
	$ctypes =~ s/,/' ' . shift(@tmpargs) . '_,'/eg;
	$ctypes =~ s/,$//;
	$ctypes =~ s/env_/env/;
	$ctypes =~ s/obj_/obj/;
	print "\t$ctypes\n" if $DEBUG;

	my $jlen = @jargs + 1;

	(my $mangclass = $class) =~ s/_/_1/g;
	(my $mangmethod = $method) =~ s/_/_1/g;
	my $plname = $cname;
	$plname =~ s/^Java_${mangclass}_${mangmethod}/JPL::${class}::${method}/;
	$plname =~ s/Ljava_lang_String_2/s/g;

	# Make glue code for each argument.

	(my $sig = $signature) =~ s/^\(//;

	my $decls = "";
	my $glue = "";

	foreach my $jarg (@jargs) {
	    if ($sig =~ s/^[ZBCSI]//) {
		$glue .= <<"";
!    /* $jarg */
!    PUSHs(sv_2mortal(newSViv(${jarg}_)));
!

	    }
	    elsif ($sig =~ s/^[JFD]//) {
		$glue .= <<"";
!    /* $jarg */
!    PUSHs(sv_2mortal(newSVnv(${jarg}_)));
!

	    }
	    elsif ($sig =~ s#^Ljava/lang/String;##) {
		$glue .= <<"";
!    /* $jarg */
!    tmpjb = (jbyte*)(*env)->GetStringUTFChars(env,${jarg}_,0);
!    PUSHs(sv_2mortal(newSVpv((char*)tmpjb,0)));
!    (*env)->ReleaseStringUTFChars(env,${jarg}_,tmpjb);
!

	    }
	    elsif ($sig =~ s/^L([^;]*);//) {
		my $pclass = j2p_class($1);
		$classseen{$pclass}++;
		$glue .= <<"";
!    /* $jarg */
!    if (!${jarg}_stashhv_)
!	${jarg}_stashhv_ = gv_stashpv("$pclass", TRUE);
! 
!    PUSHs(sv_bless(
!	sv_setref_iv(sv_newmortal(), Nullch, (IV)(void*)${jarg}_),
!	${jarg}_stashhv_));
!    if (jpldebug)
!	fprintf(stderr, "Done with $jarg\\n");
!

		$decls .= <<"";
!    static HV* ${jarg}_stashhv_ = 0;


	    }
	    elsif ($sig =~ s/^\[+([ZBCSIJFD]|L[^;]*;)//) {
		my $pclass = "jarray";
		$classseen{$pclass}++;
		$glue .= <<"";
!    /* $jarg */
!    if (!${jarg}_stashhv_)
!	${jarg}_stashhv_ = gv_stashpv("$pclass", TRUE);
! 
!    PUSHs(sv_bless(
!	sv_setref_iv(sv_newmortal(), Nullch, (IV)(void*)${jarg}_),
!	${jarg}_stashhv_));
!    if (jpldebug)
!	fprintf(stderr, "Done with $jarg\\n");
!

		$decls .= <<"";
!    static HV* ${jarg}_stashhv_ = 0;

	    }
	    else {
		die "Short signature: $signature\n" if $sig eq "";
		die "Unrecognized letter '" . substr($sig, 0, 1) . "' in signature $signature\n";
	    }
	}

	$sig =~ s/^\)// or die "Argument mismatch in signature: $method$signature\n";

	my $void = $signature =~ /\)V$/;

	$decls .= <<"" if $signature =~ m#java/lang/String#;
!    jbyte* tmpjb;

	$decls .= <<"" unless $void;
!    SV* retsv;
!    $rettype retval;
!
!    if (jpldebug)
!	fprintf(stderr, "Got to $cname\\n");
!    ENTER;
!    SAVETMPS;

	emit <<"";
!JNIEXPORT $rettype JNICALL
!$cname($ctypes)
!{
!    static SV* methodsv = 0;
!    static HV* stashhv = 0;
!    dSP;
$decls
!    PUSHMARK(sp);
!    EXTEND(sp,$jlen);
!
!    sv_setiv(perl_get_sv("JPL::_env_", 1), (IV)(void*)env);
!    jplcurenv = env;
!
!    if (jpldebug)
!	fprintf(stderr, "env = %lx\\n", (long)$env);
!
!    if (!methodsv)
!	methodsv = (SV*)perl_get_cv("$plname", TRUE);
!    if (!stashhv)
!	stashhv = gv_stashpv("JPL::$class", TRUE);
! 
!    if (jpldebug)
!	fprintf(stderr, "blessing obj = %lx\\n", obj);
!    PUSHs(sv_bless(
!	sv_setref_iv(sv_newmortal(), Nullch, (IV)(void*)obj),
!	stashhv));
!
$glue

	# Finally, call the subroutine.

	my $mod;
	$mod = "|G_DISCARD" if $void;

	if ($void) {
	    emit <<"";
!    PUTBACK;
!    perl_call_sv(methodsv, G_EVAL|G_KEEPERR|G_DISCARD);
!

	}
	else {
	    emit <<"";
!    PUTBACK;
!    if (perl_call_sv(methodsv, G_EVAL|G_KEEPERR))
!	retsv = *PL_stack_sp--;
!    else
!	retsv = &PL_sv_undef;
!

	}

	emit <<"";
!    if (SvTRUE(ERRSV)) {
!	jthrowable newExcCls;
!
!	(*env)->ExceptionDescribe(env);