use strict;
use warnings;
use UNIVERSAL;

package CORBA::XPIDL::javaVisitor;

use File::Basename;

sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;
	my $self = {};
	bless($self, $class);
	my ($parser) = @_;
	$self->{srcname} = $parser->YYData->{srcname};
	$self->{symbtab} = $parser->YYData->{symbtab};
	my $filename;
	if ($parser->YYData->{opt_e}) {
		$filename = $parser->YYData->{opt_e};
	}
	else {
		if ($parser->YYData->{opt_o}) {
			$filename = $parser->YYData->{opt_o} . '.java';
		}
		else {
			$filename = basename($self->{srcname}, '.idl') . '.java';
		}
	}
	$self->open_stream($filename);
	$self->{num_key} = 'num_doc_xp';
	return $self;
}

sub open_stream {
	my $self = shift;
	my ($filename) = @_;
	open $self->{out}, '>', $filename
			or die "can't open $filename ($!).\n";
	$self->{filename} = $filename;
}

sub _get_defn {
	my $self = shift;
	my ($defn) = @_;
	if (ref $defn) {
		return $defn;
	}
	else {
		return $self->{symbtab}->Lookup($defn);
	}
}

sub _classname_iid {
	my $self = shift;
	my ($node) = @_;
	my $idf = $node->{idf};
	$idf =~ s/^ns/NS_/;		# backcompat naming styles
	my $classname = uc $idf;
	$classname .= '_IID';
	return $classname;
}

sub _comment {
	my $self = shift;
	my ($node) = @_;
	return q{} unless ($node->{doc});
	my $FH = $self->{out};
	my $indent = q{    };
	print $FH $indent,"/**\n";
	foreach (split /\n/, $node->{doc}) {
		s/^\s+//;
		next unless ($_);
		print $FH $indent," * ",$_,"\n";
	}
	print $FH $indent," */\n";
}

sub _java_type {
	my $self = shift;
	my ($node) = @_;

	while ($node->isa('TypeDeclarator')) {
		$node = $self->_get_defn($node->{type});
	}

	if    ($node->isa('VoidType')) {
		return 'Object';
	}
	elsif ($node->isa('IntegerType')) {
		if    ($node->{value} eq 'short') {
			return 'short';
		}
		elsif ($node->{value} eq 'unsigned short') {
			return 'short';
		}
		elsif ($node->{value} eq 'long') {
			return 'int';
		}
		elsif ($node->{value} eq 'unsigned long') {
			return 'int';
		}
		elsif ($node->{value} eq 'long long') {
			return 'long';
		}
		elsif ($node->{value} eq 'unsigned long long') {
			return 'long';
		}
		else {
			warn __PACKAGE__,"::_java_type (IntegerType) $node->{value}.\n";
		}
	}
	elsif ($node->isa('CharType')) {
		return 'char';
	}
	elsif ($node->isa('WideCharType')) {
		return 'char';
	}
	elsif ($node->isa('StringType')) {
		return 'String';
	}
	elsif ($node->isa('WideStringType')) {
		return 'String';
	}
	elsif ($node->isa('BooleanType')) {
		return 'boolean';
	}
	elsif ($node->isa('OctetType')) {
		return 'byte';
	}
	elsif ($node->isa('FloatingPtType')) {
		if    ($node->{value} eq 'float') {
			return 'float';
		}
		elsif ($node->{value} eq 'double') {
			return 'double';
		}
		elsif ($node->{value} eq 'long double') {
			warn __PACKAGE__," 'long double' not available at this time for Java.\n";
			return 'double';
		}
		else {
			warn __PACKAGE__,"::_java_type (FloatingType) $node->{value}.\n";
		}
	}
	elsif ($node->isa('NativeType')) {
		if    (  $node->{native} eq 'void' ) {
			return 'Object';
		}
		elsif (  $node->{native} eq 'nsID'
				or $node->{native} eq 'nsIID'
				or $node->{native} eq 'nsCID' ) {
			# XXX: s.b test for "iid" attribute
			# XXX: special class for nsIDs
			return 'nsID';
		}
		else {
			# XXX: special class for opaque types
			return 'OpaqueValue';
		}
	}
	elsif ($node->isa('BaseInterface')) {
		return $node->{idf};
	}
	elsif ($node->isa('ForwardBaseInterface')) {
		return $node->{idf};
	}
	else {
		my $class = ref $node;
		warn __PACKAGE__,"::_java_type unknown type ($class).\n";
	}
}

#
#	3.5		OMG IDL Specification
#

sub visitSpecification {
	my $self = shift;
	my ($node) = @_;
	my $FH = $self->{out};

	print $FH "/*\n";
	print $FH " * ************* DO NOT EDIT THIS FILE ***********\n";
	print $FH " *\n";
	print $FH " * This file was automatically generated from ",$self->{srcname},".\n";
	print $FH " */\n";
	print $FH "\n";
	foreach (@{$node->{list_decl}}) {
		$self->_get_defn($_)->visit($self);
	}
	print $FH "\n";
	print $FH "/*\n";
	print $FH " * end\n";
	print $FH " */\n";
	close $FH;
}

#
#	3.6		Import Declaration
#

sub visitImport {
	# empty
}

#
#	3.7		Module Declaration
#

sub visitModules {
	my $self = shift;
	my ($node) = @_;
	unless (exists $node->{$self->{num_key}}) {
		$node->{$self->{num_key}} = 0;
	}
	my $module = ${$node->{list_decl}}[$node->{$self->{num_key}}];
	$module->visit($self);
	$node->{$self->{num_key}} ++;
}

sub visitModule {
	my $self = shift;
	my ($node) = @_;
	foreach (@{$node->{list_decl}}) {
		$self->_get_defn($_)->visit($self);
	}
}

#
#	3.8		Interface Declaration
#

sub visitBaseInterface {
	# empty
}

sub visitRegularInterface {
	my $self = shift;
	my ($node) = @_;
	return unless ($self->{srcname} eq $node->{filename});
	my $FH = $self->{out};

	# Write out JavaDoc comment
	print $FH "\n";
	print $FH "/**\n";
	print $FH " * Interface ",$node->{idf},"\n";
	my $iid = $node->getProperty('uuid');
	if (defined $iid) {
		print $FH " *\n";
		print $FH " * IID: 0x",$iid,"\n";
	}
	print $FH " */\n";
	print $FH "\n";

	# Write "public interface <foo>"
	print $FH "public interface ",$node->{idf};
	if (exists $node->{inheritance}) {
		print $FH " extends ";
		my $first = 1;
		foreach (@{$node->{inheritance}->{list_interface}}) {
			my $base = $self->_get_defn($_);
			print $FH ", " unless ($first);
			print $FH $base->{idf};
			$first = 0;
		}
	}
	print $FH "\n";
	print $FH "{\n";
	if (defined $iid) {
		my $classname_iid = $self->_classname_iid($node);
		# Write interface constants for IID
		print $FH "    public static final String ",$classname_iid,"_STRING =\n";
		print $FH "        \"",$iid,"\";\n";
		print $FH "\n";
		print $FH "    public static final nsID ",$classname_iid," =\n";
		print $FH "        new nsID(\"",$iid,"\");\n";
		print $FH "\n";
	}

	foreach (@{$node->{list_decl}}) {
		$self->_get_defn($_)->visit($self);
	}
	print $FH "}\n";
	print $FH "\n";
}

sub visitForwardBaseInterface {
	# empty
}

#
#	3.10		Constant Declaration
#

sub visitConstant {
	my $self = shift;
	my ($node) = @_;
	my $FH = $self->{out};

	my $type = $self->_get_defn($node->{type});
	my $java_type = $self->_java_type($type);
	my $value = $node->{value}->{value};
	print $FH "\n";
	$self->_comment($node);
	print $FH "    public static final ",$java_type," ",$node->{idf}," = ",$value,";\n";
}

sub visitExpression {
	# empty
}

#
#	3.11	Type Declaration
#

sub visitTypeDeclarators {
	# empty
}

sub visitNativeType {
	# empty
}

#
#	3.11.2	Constructed Types
#

sub visitStructType {
	# empty
}

sub visitUnionType {
	# empty
}

sub visitForwardStructType {
	# empty
}

sub visitForwardUnionType {
	# empty
}

#	3.11.2.4	Enumerations
#

sub visitEnumType {
	# empty
}

#
#	3.12	Exception Declaration
#

sub visitException {
	# empty
}

#
#	3.13	Operation Declaration
#

sub visitOperation {
	my $self = shift;
	my ($node) = @_;
	my $FH = $self->{out};

	my $method_notxpcom = $node->hasProperty('notxpcom');
	my $method_noscript = $node->hasProperty('noscript');

	print $FH "\n";
	$self->_comment($node);

	# Write beginning of method declaration
	print $FH "    ";
	# Nonscriptable methods become package-protected
	print $FH "public " unless ($method_noscript);

	# Write return type
	# Unlike C++ headers, Java interfaces return the declared
	# return value; an exception indicates XPCOM method failure.
	my $type = $self->_get_defn($node->{type});
	if ($method_notxpcom or !$type->isa('VoidType')) {
		print $FH $self->_java_type($type);
	}
	else {
		# Check for retval attribute
		my $retval_param;
		foreach (@{$node->{list_param}}) {
			if ($_->hasProperty('retval')) {
				$retval_param = $_;
				last;
			}
		}
		if (defined $retval_param) {
			$type = $self->_get_defn($retval_param->{type});
			print $FH $self->_java_type($type);
		}
		else {
			print $FH "void";
		}
	}

	# Write method name
	print $FH " ",lcfirst($node->{idf}),"(";

	# Write parameters
	my $first = 1;
	foreach (@{$node->{list_param}}) {
		# Skip "retval"
		next if ($_->hasProperty('retval'));
		print $FH ", " unless ($first);
		# Put in type of parameter
		$type = $self->_get_defn($_->{type});
		print $FH $self->_java_type($type);
		# If the parameter is out or inout, make it a Java array of the
		# appropriate type
		print $FH "[]" if ($_->{attr} ne "in");
		#Put in name of parameter
		print $FH " ",$_->{idf};
		$first = 0;
	}
	print $FH ")";

	if (exists $node->{list_raise}) {
		print $FH " throws ";
		$first = 1;
		foreach (@{$node->{list_raise}}) {		# exception
			my $defn = $self->_get_defn($_);
			print $FH ", " unless ($first);
			print $FH $defn->{idf};
			$first = 0;
		}
	}

	print $FH ";\n";
}

#
#	3.14	Attribute Declaration
#

sub visitAttributes {
	my $self = shift;
	my ($node) = @_;

	foreach (@{$node->{list_decl}}) {
		$self->_get_defn($_)->visit($self);
	}
}

sub visitAttribute {
	my $self = shift;
	my ($node) = @_;
	my $FH = $self->{out};

	my $method_noscript = $node->hasProperty('noscript');
	my $type = $self->_get_defn($node->{type});

	print $FH "\n";
	$self->_comment($node);

	# Write access permission ("public" unless nonscriptable)
	print $FH "    ";
	print $FH "public " unless ($method_noscript);
	# Write the proper Java return value for the get operation
	print $FH $self->_java_type($type);
	# Write the name of the accessor ("get") method.
	print $FH " get",ucfirst($node->{idf}),"();\n";

	unless (exists $node->{modifier}) {		# readonly
		# Nonscriptable methods become package-protected
		print $FH "    ";
		print $FH "public " unless ($method_noscript);
		# Write attribute access method name and return type
		print $FH "void set",ucfirst($node->{idf}),"(";
		# Write the proper Java type for the set operation
		print $FH $self->_java_type($type);
		# Write the name of the formal parameter.
		print $FH " value);\n"
	}
}

#
#	3.15	Repository Identity Related Declarations
#

sub visitTypeId {
	# empty
}

sub visitTypePrefix {
	# empty
}

#
#	XPIDL
#

sub visitCodeFragment {
	# empty
}

1;

