#Copyright Massachusetts Institute of technology, 1998.
#Written by Eric Prud'hommeaux for the World Wide Web Consortium

use strict;
require Exporter;
#require AutoLoader;


$W3C::JVM::JVM::REVISION = '$Id: JVM.pm,v 1.33 2003/12/09 10:31:54 eric Exp $ ';

package W3C::JVM::JVM;
use vars qw($VERSION $DSLI @ISA @TODO @EXPORT_OK);
@ISA = qw(W3C::Util::NamedParmObject Exporter); # AutoLoader);
@TODO = qw();
@EXPORT_OK = qw(&javaClass2PerlPackage);
$VERSION = 0.0;
$DSLI = 'adpO';

use W3C::Util::Exception;
use W3C::Util::Object;
use W3C::JVM::ClassFile;
use W3C::JVM::StackFrame;
use W3C::JVM::Instruction qw($InstructionTable);
use W3C::JVM::BuiltIn qw($BuiltIn);

sub new {
    my ($proto, $main, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    $self->{BY_NAME} = {};
    my $mainClass = $self->_readClass($main);
    $self->{MAIN_NAME} = $mainClass->getClassName();
    return $self;
}

sub execute {
    my ($self) = @_;
    my $mainClassFile = $self->{BY_NAME}{$self->{MAIN_NAME}};
    my $pool = $mainClassFile->getConstantPool();
    my $argv = $pool->ensureString(join (' ', @ARGV));
    my $mainClass = $pool->ensureClassRef($self->{MAIN_NAME});
    my $mainMethod = $pool->ensureUtf8('main');
    my $mainType = $pool->ensureUtf8('([Ljava/lang/String;)V');
    $self->executeMethod($pool->ensureMethodRef($mainClass, $mainMethod, $mainType), [$argv], 1, 0);
}

sub registerClass {
    my ($self, $classFile) = @_;
    $self->{BY_NAME}{$classFile->getClassName()} = $classFile;
}

sub toString {
    my ($self, $flags) = @_;
    $flags ||= {};
}

sub _readClass {
    my ($self, $classFile) = @_;
    open (CLASSFILE, $classFile) || &throw(new W3C::Util::FileNotFoundException(-filename => $classFile));
    my @class = <CLASSFILE>;
    my $bits = join ('', @class);
    my $class = new W3C::JVM::ClassFile(\$bits, $self, {$self->{-resolveLocal}});
    return $class;
}

sub executeMethod {
    my ($self, $methodRef, $callerStack, $static, $special) = @_;
    my $args = &_buildArgumentList($callerStack, $methodRef, $static);

    my $class = $methodRef->getClass();
    my $classFile = $self->{BY_NAME}{$class->toString()};
    my $methodName = $methodRef->getMethod();
    my $method = $classFile ? $classFile->getMethod($methodName->toString(), $methodRef->getTypeString()) : undef;
    if ($method) {
	if ($self->{-compile}) {
	    my $code = $self->compile($class, $method, $classFile);
#	    print $code;
	    eval $code;
	    if ($@) {
		print "$code\n";
		if (my $ex = &catch('W3C::Util::Exception')) {
		    print $ex->toString;
#    die $@.' at line '.$tester->{XML_PARSER}->getLineNumber.' column '.$tester->{XML_PARSER}->getColumnNumber;
		} else {
		    print $@;
		}
		return;
	    }
	    my $classStr = &javaClass2PerlPackage($class);
	    my $methodStr = &javaMethod2PerlMethod($methodRef); # $methodName->toString();
	    my $start = "&${classStr}::$methodStr(\@ARGV)";
	    eval $start;
	    if ($@) {
		print "$code\n$@";
	    }
	} else {
	    my $byteCode = $method->getByteCode();
	    my $stack = [];
	    my $vars = [@$args];
	    my $pc = 0;
	    my $done = 0;
	    do {
		my $instruction = $InstructionTable->[$byteCode->[$pc]];
		if (!defined $instruction) {
		    &throw(new W3C::Util::NotImplementedException(-class => 'W3C::JVM::Instruction', 
								  -method => "($byteCode->[$pc])"));
		}
		my ($parms, $types, $iParm) = $instruction->getParms($byteCode, $pc, $classFile->getConstantPool());
		if (my $perl = $instruction->getInterpreterCode()) {
		    eval $perl;
		    if ($@) {
			&throw($instruction->makeException($@));
		    }
		} else {
		    print 'failing to execute '.$instruction->toString($byteCode, $pc, $parms, $types)."\n";
		}
		$pc += $iParm + 1;
	    } while (!$done);
	}
    } elsif (my $method = &_resolveMethod($args->[0], $methodRef, 1)) {
	$self->javaArgs2PerlArgs($args, 0);
#	print "resolved: \&$method($$this, @$args)\n";
	my $ret;
	my $pkg = &javaClass2PerlPackage($methodRef->getClass());
	eval "require $pkg";
	no strict;
	$ret = &$method(@$args);
	use strict;
	if ($@) {&throw()}
	if ($methodRef->getReturnType()) {
	    push (@$callerStack, &perlPackage2JavaClass($ret));
	}
    } elsif (my $method = $BuiltIn->{$class->toString()}{$methodName->toString()}{$methodRef->getTypeString()}) {
#	print 'BuiltIn', $method->toString(), "\n";
	eval $method->getCode();
	if ($@) {&throw()}
    } else {
	&throw(new W3C::Util::NotImplementedException());
    }
}

sub putField {
    my ($self, $fieldRef, $callerStack, $static, $special) = @_;
    my $value = pop (@$callerStack);
    my $instance = pop (@$callerStack);
    $instance->{VARS}{$fieldRef->getField->getConst} = $value;
}

# private methods

sub disassemble {
    my ($self, $byteCode, $pool, $flags) = @_;
    $flags ||= {};
    my $ret = [];
    for (my $pc = 0; $pc < @$byteCode;) {
	my $instruction = $InstructionTable->[$byteCode->[$pc]];
	if (!defined $instruction) {
	    push (@$ret, '...');
	    return $ret;
	    &throw(new W3C::Util::NotImplementedException());
	}
	my ($parms, $types, $iParm) = $instruction->getParms($byteCode, $pc, $pool);
	my $str = $instruction->disassemble($byteCode, $pc, $parms, $types, {-showInterpreterCode => 1, -showCompilerCode => 1, %$flags});
	push (@$ret, $str);
	$pc += $iParm + 1;
    }
    return $ret;
}

sub compile {
    my ($self, $class, $method, $classFile) = @_;

    my $ret = [];
    my $HEADER = "#!/usr/bin/perl\nuse strict;\nuse W3C::JVM::JavaClasses::java::lang::Object;";
    push (@$ret, $HEADER);
    my $pkg = &javaClass2PerlPackage($class);
    push (@$ret, "package $pkg;");
    push (@$ret, "\@${pkg}::ISA = qw(W3C::JVM::JavaClasses::java::lang::Object);");

    foreach my $methodRef ($classFile->getMethods()) {
	push (@$ret, $self->compileMethod($methodRef, $classFile));
    }
    return join ("\n", @$ret);
}

sub compileMethod {
    my ($self, $method, $classFile) = @_;
    my $ret = [];

    my $byteCode = $method->getByteCode();
    my $pool = $classFile->getConstantPool();
    my $stack = [];
    my $vars = [];
    my $pc = 0;
    my $byPc = [];
    my $gotoTargets = {};

    for (my $pc = 0; $pc < @$byteCode;) {
	my $instruction = $InstructionTable->[$byteCode->[$pc]];
	if (!defined $instruction) {
	    $byPc->[$pc] = "...";
	    last;
#	    &throw($instruction->makeException($@));
	}

	my ($parms, $types, $iParm) = $instruction->getParms($byteCode, $pc, $pool);
	if (my $perl = $instruction->getCompilerCode()) {
	    my $tmp;
	    my $t2;
	    my $t3;
	    $byPc->[$pc] = eval $perl;
	    if ($@) {
		if (my $ex = &catch('W3C::Util::Exception')) {
		    $byPc->[$pc] = 'eval problem '.$ex->toString;
		} else {
		    $byPc->[$pc] = "eval problem $@";
		}
#		&throw($instruction->makeException($@));
	    }
	} else {
	    print 'failing to compile '.$instruction->toString($byteCode, $pc, $parms, $types)."\n";
	}
	$pc += $iParm + 1;
    }

    foreach my $useString ($classFile->getUseStrings()) {
	push (@$ret, $useString);
    }
    # $method->{NAME_REF}->getConst()
    my $methodName = &javaMethod2PerlMethod($method->getMethodRef); # $method->getName()->toString();
    push (@$ret, undef);
    push (@$ret, "sub $methodName {\n    my \$vars = [];\n");
    for (my $i = 0; $i < @$byPc; $i++) {
	if ($gotoTargets->{$i}) {
	    push (@$ret, "  L$i:");
	}
	if ($byPc->[$i]) {
	    push (@$ret, '    '.$byPc->[$i]);
	}
    }
    push (@$ret, "}\n");
    return @$ret;
}

sub compile_invoke {
    my ($self, $callerStack, $static, $methodRef, $special) = @_;
    my $args = &_buildArgumentList($callerStack, $methodRef, $static);

    if (my $method = &_resolveMethodName($args->[0], $methodRef, $self->{-resolveLocal})) {
	$self->javaArgs2PerlArgs($args, 1);
	my $this = shift @$args;
	my $argStr = join (', ', @$args);
#	return "$this->$method(\@\$args);";
	return "$this->$method($argStr);";
    } else {
	my $thisStr = $args->[0]->toString();
	my $methodStr = $methodRef->toString();
	return "couldn't find $thisStr->$methodStr";
    }
}

# javaArgs2PerlArgs - convert java references and the like to 

sub javaArgs2PerlArgs {
    my ($self, $args, $quote) = @_;
    for (my $i = 0; $i < @$args; $i++) {
	my $arg = $args->[$i];
#	eval "\$ret = \${\$this}->$method(\@\$args)";
	if (!ref $arg || ref $arg eq 'SCALAR') {
#	    $arg = "\"$arg\"";
	} elsif ($arg->isa('W3C::JVM::UninitializedObject')) {
	    # special case for new  uniitialized objects
	    $arg = $arg->getClassName();
	} elsif ($arg->isa('W3C::JVM::ConstantPoolEntry::Entry')) {
	    $arg = $arg->toPerl($quote);
	} else {
	    &throw(new W3C::Util::ProgramFlowException());
	}
	$args->[$i] = $arg;
    }
    return $args;
}

sub javaClass2PerlPackage { # static
    my ($class) = @_;
    my $classStr = $class->toString();
    $classStr =~ s/\//::/g;
    return "W3C::JVM::JavaClasses::$classStr";
}

sub perlPackage2JavaClass { # static
    my ($pkg) = @_;
    return $pkg;
}

sub javaMethod2PerlMethod { # static
    my ($methodref) = @_;
    my $methodName = $methodref->getMethod()->toString();
    if ($methodName eq '<init>') {
	$methodName = 'new';
    }
    my $typeNames = $methodref->getTypes;
    if (@$typeNames) {
	my @mangled;
	foreach my $tmp (@$typeNames) {
	    my $typeName = $tmp;
	    $typeName =~ s/_/__/g;
	    $typeName =~ s/\//_u/g;
	    $typeName =~ s/\;/_s/g;
	    $typeName =~ s/\</_l/g;
	    $typeName =~ s/\>/_g/g;
	    $typeName =~ s/\[/_a/g;
	    push (@mangled, $typeName);
	}
	my $typeName = join ('_z', @mangled);
	return "${methodName}_$typeName";
    } else {
	return $methodName;
    }
}

sub splitBytes {
    my ($self, $word) = @_;
    return (int($word / 256), $word % 256);
}

sub maybeSplitBytes {
    my ($self, $unknown) = @_;
    return ($unknown > 256) ? $self->splitBytes($unknown) : $unknown;
}

sub _resolveMethod { # static
    my ($this, $methodref, $checkLocal) = @_;
#    print "_resolveMethod: $this\n";
    my $perlMethod = &javaMethod2PerlMethod($methodref);
    return &javaClass2PerlPackage($methodref->getClass()).'::'.$perlMethod;
    my $ret;
    eval "\$ret = \${\$this}->can('$perlMethod')";
    if (!$ret && $checkLocal) {
	eval 'require '.ref $$this;
	eval "\$ret = \${\$this}->can('$perlMethod')";
    }
    return $ret ? $perlMethod : undef;
}

sub _resolveMethodName { # static
    my ($this, $methodref, $checkLocal) = @_;
#    print "_resolveMethodName: $this\n";
    my $perlMethod = &javaMethod2PerlMethod($methodref);
    if ($checkLocal) {
	my $ret;
	eval "\$ret = $this->can('$perlMethod')";
	return $ret ? $perlMethod : undef;
    } else {
	return $perlMethod;
    }
}

sub _buildArgumentList { # static
    my ($callerStack, $methodRef, $static) = @_;
    my $takes = $methodRef->getTypes();
    my $passCount = scalar @$takes;
    if (!$static) {
	$passCount++;
    }
    my $args = [];
    for (my $i = 0; $i < $passCount; $i++) {
	my $arg = pop (@$callerStack);
	unshift (@$args, $arg);
    }
    return $args;
}

1;

