kolibrios/programs/network/netsurf/libdom/test/DOMTSHandler.pm

# This is the PerSAX Handlers Package

package DOMTSHandler;

use Switch;

use XML::XPath;
use XML::XPath::XMLParser;

our $description = 0;
our $string_index = 0;
our $ret_index = 0;
our $condition_index = 0;
our $test_index = 0;
our $iterator_index = 0;
our $temp_index = 0;
# Sometimes, we need temp nodes
our $tnode_index = 0;
our $dom_feature = "\"XML\"";
our %bootstrap_api = (
	dom_implementation_create_document_type => "",
	dom_implementation_create_document	=> "",
);
our %native_interface = (
	DOMString => \&generate_domstring_interface,
	DOMTimeStamp => "",
	DOMUserData => "",
	DOMObject =>"",
);
our %special_type = (
	# Some of the type are not defined now!
	boolean => "bool ",
	int => "int32_t ",
	"unsigned long" => "uint32_t ",
	DOMString => "dom_string *",
	List => "list *",
	Collection => "list *",
	DOMImplementation => "dom_implementation *",
	NamedNodeMap => "dom_namednodemap *",
	NodeList => "dom_nodelist *",
        HTMLCollection => "dom_html_collection *",
        HTMLFormElement => "dom_html_form_element *",
	CharacterData => "dom_characterdata *",
	CDATASection => "dom_cdata_section *",
);
our %special_prefix = (
	DOMString => "dom_string",
	DOMImplementation => "dom_implementation",
	NamedNodeMap => "dom_namednodemap",
	NodeList => "dom_nodelist",
        HTMLCollection => "dom_html_collection",
        HTMLFormElement => "dom_html_form_element",
	CharacterData => "dom_characterdata",
	CDATASection => "dom_cdata_section *",
);

our %unref_prefix = (
	DOMString => "dom_string",
	NamedNodeMap => "dom_namednodemap",
	NodeList => "dom_nodelist",
        HTMLCollection => "dom_html_collection",
);

our %special_method = (
);

our %special_attribute = (
	namespaceURI => "namespace",
);

our %no_unref = (
	"boolean" => 1,
	"int" => 1,
	"unsigned int" => 1,
	"List" => 1,
	"Collection" => 1,
);

our %override_suffix = (
	boolean => "bool",
	int => "int",
	"unsigned long" => "unsigned_long",
	DOMString => "domstring",
	DOMImplementation => "domimplementation",
	NamedNodeMap => "domnamednodemap",
	NodeList => "domnodelist",
        HTMLCollection => "domhtmlcollection",
	Collection => "list",
	List => "list",
);

our %exceptions = (
	
	DOM_NO_ERR			=>  0,
	DOM_INDEX_SIZE_ERR		=>  1,
	DOM_DOMSTRING_SIZE_ERR		=>  2,
	DOM_HIERARCHY_REQUEST_ERR	=>  3,
	DOM_WRONG_DOCUMENT_ERR		=>  4,
	DOM_INVALID_CHARACTER_ERR	=>  5,
	DOM_NO_DATA_ALLOWED_ERR		=>  6,
	DOM_NO_MODIFICATION_ALLOWED_ERR	=>  7,
	DOM_NOT_FOUND_ERR		=>  8,
	DOM_NOT_SUPPORTED_ERR		=>  9,
	DOM_INUSE_ATTRIBUTE_ERR		=> 10,
	DOM_INVALID_STATE_ERR		=> 11,
	DOM_SYNTAX_ERR			=> 12,
	DOM_INVALID_MODIFICATION_ERR	=> 13,
	DOM_NAMESPACE_ERR		=> 14,
	DOM_INVALID_ACCESS_ERR		=> 15,
	DOM_VALIDATION_ERR		=> 16,
	DOM_TYPE_MISMATCH_ERR		=> 17,

	DOM_UNSPECIFIED_EVENT_TYPE_ERR  => (1<<30)+0,
	DOM_DISPATCH_REQUEST_ERR        => (1<<30)+1,

	DOM_NO_MEM_ERR			=> (1<<31)+0, 
);

our @condition = qw(same equals notEquals less lessOrEquals greater greaterOrEquals isNull notNull and or xor not instanceOf isTrue isFalse hasSize contentType hasFeature implementationAttribute);

our @exception = qw(INDEX_SIZE_ERR DOMSTRING_SIZE_ERR HIERARCHY_REQUEST_ERR WRONG_DOCUMENT_ERR INVALID_CHARACTER_ERR NO_DATA_ALLOWED_ERR NO_MODIFICATION_ALLOWED_ERR NOT_FOUND_ERR NOT_SUPPORTED_ERR INUSE_ATTRIBUTE_ERR NAMESPACE_ERR UNSPECIFIED_EVENT_TYPE_ERR DISPATCH_REQUEST_ERR);

our @assertion = qw(assertTrue assertFalse assertNull assertNotNull assertEquals assertNotEquals assertSame assertInstanceOf assertSize assertEventCount assertURIEquals);

our @assertexception = qw(assertDOMException assertEventException assertImplementationException);

our @control = qw(if while for-each else);

our @framework_statement = qw(assign increment decrement append plus subtract mult divide load implementation comment hasFeature implementationAttribute EventMonitor.setUserObj EventMonitor.getAtEvents EventMonitor.getCaptureEvents EventMonitor.getBubbleEvents EventMonitor.getAllEvents wait);

sub new {
	my $type = shift;
	my $dtd = shift;
        my $chdir = shift;
	my $dd = XML::XPath->new(filename => $dtd);
	my $self = {
			# The DTD file of the xml files
			dd => $dd,
			# To indicate whether we are in comments
			comment => 0,
			# To indicate that whether we are in <comment> element
			inline_comment => 0,
			# The stack of elements encountered utill now
			context => [],
			# The map for <var> name => type
			var => {},
			# See the comment on generate_condition2 for this member
			condition_stack => [],
			# The list for UNREF
			unref => [],
			string_unref => [],
			# The indent of current statement
			indent => "",
			# The variables for List/Collection
			# We now, declare an array for a list and then add them into a list
			# The map for all the List/Collection in one test
			# "List Name" => "Member type"
			list_map => {},
			# The name of the current List/Collection
			list_name => "",
			# The number of items of the current List/Collection
			list_num => 0,
			# Whether List/Collection has members
			list_hasmem => 0,
			# The type of the current List/Collection
			list_type => "",
			# Whether we are in exception assertion
			exception => 0,
                        # Where to chdir
                        chdir => $chdir
			};

	return bless $self, $type;
}

sub start_element {
	my ($self, $element) = @_;

	my $en = $element->{Name};

	my $dd = $self->{dd};
	my $ct = $self->{context};
	push(@$ct, $en);

	switch ($en) {
		case "test" {
			;
		}
		case "metadata" {
			# start comments here
			print "/*\n";
			$self->{comment} = 1;
		}

		# Print the var definition
		case "var" {
			$self->generate_var($element->{Attributes});
		}

		case "member" {
			if ($self->{context}->[-2] eq "var") {
				if ($self->{"list_hasmem"} eq 1) {
					print ", ";
				}
				$self->{"list_hasmem"} = 1;
				$self->{"list_num"} ++;
			}
		}


		# The framework statements
		case [@framework_statement] {
			# Because the implementationAttribute & hasFeature belongs to both 
			# framework-statement and condition, we should distinct the two 
			# situation here. Let the generate_condtion to do the work.
			if ($en eq "hasFeature" || $en eq "implementationAttribute") {
				next;
			}

			$self->generate_framework_statement($en, $element->{Attributes});
		}

		case [@control] {
			$self->generate_control_statement($en, $element->{Attributes});
		}

		# Test condition
		case [@condition] {
			$self->generate_condition($en, $element->{Attributes});
		}

		# The assertsions
		case [@assertion] {
			$self->generate_assertion($en, $element->{Attributes});
		}
		
		case [@assertexception] {
			# Indeed, nothing to do here!
		}

		# Deal with exception
		case [@exception] {
			# Just see end_element
			$self->{'exception'} = 1;
		}

		# Then catch other case
		else {
			# we don't care the comment nodes
			if ($self->{comment} eq 0) {
				$self->generate_interface($en, $element->{Attributes});
			}
		}
	}
}

sub end_element {
	my ($self, $element) = @_;

	my @ct = @{$self->{context}};
	my $name = pop(@{$self->{context}});

	switch ($name) {
		case "metadata" {
			print "*/\n";
			$self->{comment} = 0;
			$self->generate_main();
		}
		case "test" {
			$self->cleanup();
		}

		case "var" {
			$self->generate_list();
		}

		# End of condition
		case [@condition] {
			$self->complete_condition($name);
		}

		# The assertion
		case [@assertion] {
			$self->complete_assertion($name);
		}

		case [@control] {
			$self->complete_control_statement($name);
		}

		case [@exception] {
			$name = "DOM_".$name;
			print "assert(exp == $exceptions{$name});\n";
			$self->{'exception'} = 0;
		}

	}
}

sub characters {
	my ($self, $data) = @_;
	our $description;

	my $ct = $self->{context};

	if ($self->{"inline_comment"} eq 1) {
		print "$data->{Data}";
		return ;
	}

	# We print the comments here
	if ($self->{comment} eq 1) {
		# So, we are in comments state
		my $top = $ct->[$#{$ct}];
		if ($top eq "metadata") {
			return;
		}

		if ($top eq "description") {
			if ($description eq 0) {
				print "description: \n";
				$description = 1;
			}
			print "$data->{Data}";
		} else {
			print "$top: $data->{Data}\n";
		}
		return;
	}

	if ($self->{context}->[-1] eq "member") {
		# We should mark that the List/Collection has members
		$self->{"list_hasmem"} = 1;

		# Here, we should detect the characters type
		# whether it is a integer or string (now, we only take care
		# of the two types, because I did not find any other type).
		if ($self->{"list_type"} eq "") {
			if ($data->{Data} =~ /^\"/) {
				$self->{"list_type"} = "char *";
				print "const char *".$self->{"list_name"}."Array[] = \{ $data->{Data}";
			} else { 
				if ($data->{Data} =~ /^[0-9]+/) {
					$self->{"list_type"} = "int *";
					print "int ".$self->{"list_name"}."Array[] = \{ $data->{Data}";
				} else {
					die "Some data in the <member> we can't process: \"$data->{Data}\"";
				}
			}
		} else {
			# So, we must have known the type, just output the member
			print "$data->{Data}";
		}
	}
}

sub generate_main {
	my $self = shift;
	# Firstly, push a new "b" to the string_unref list
	push(@{$self->{"string_unref"}}, "b");

	print << "__EOF__"

#include <stdio.h>
#include <string.h>
#include <stdbool.h>
#include <unistd.h>

#include <dom/dom.h>
#include <dom/functypes.h>

#include <domts.h>

dom_implementation *doc_impl;

int main(int argc, char **argv)
{
	dom_exception exp;

	(void)argc;
	(void)argv;

	if (chdir("$self->{chdir}") < 0) {
		perror("chdir (\\"$self->{chdir})\\"");
		return 1;
	}
__EOF__
}

# Note that, we have not just declare variables here
# we should also define EventListener here!
# I think this should be done after the EventListener design
# is complete
sub generate_var {
	my ($self, $ats) = @_;

	my $type = "";
	my $dstring = "";

	# For the case like <var name="v" type="DOMString" value="some some"
	if ($ats->{"type"} eq "DOMString" and exists $ats->{"value"}) {
		$dstring = $self->generate_domstring($ats->{"value"});
		$ats->{"value"} = $dstring;
	}

	$type = type_to_ctype($ats->{"type"});
	if ($type eq "") {
		print "Not implement this type now\n";
		return;
	}

	print "\t$type$ats->{'name'}";
	if (exists $ats->{"value"}) {
		print " = $ats->{'value'};\n";
	} else {
		if ($type =~ m/\*/) {
			print " = NULL;\n";
		} else {
			print ";\n";
		}
	}

	my $var = $self->{"var"};
	$var->{$ats->{"name"}} = $ats->{"type"};

	# If the type is List/Collection, we should take care of it
	if ($ats->{"type"} =~ /^(List|Collection)$/) {
		$self->{"list_name"} = $ats->{"name"};
	}
}

sub generate_list {
	my $self = shift;

	# We should deal with the end of <var> when the <var> is declaring a List/Collection
	if ($self->{"list_hasmem"} eq 1) {
		# Yes, we are in List/Collection declaration
		# Firstly, enclose the Array declaration
		print "};\n";

		# Now, we should create the list * for the List/Collection
		# Note, we should deal with "int" or "string" type with different params.
		if ($self->{"list_type"} eq "char *") {
			print $self->{"list_name"}." = list_new(STRING);\n";
		}
		if ($self->{"list_type"} eq "int *") {
			print $self->{"list_name"}." = list_new(INT);\n";
		}
		if ($self->{"list_type"} eq "") {
			die "A List/Collection has children member but no type is impossible!";
		}
		for (my $i = 0; $i < $self->{"list_num"}; $i++) {
			# Use *(char **) to convert char *[] to char *
			print "list_add(".$self->{"list_name"}.", *(char **)(".$self->{"list_name"}."Array + $i));\n";
		}
	} else {
		if ($self->{"list_name"} ne "") {
			#TODO: generally, we set the list type as dom_string, but it may be dom_node
			print $self->{"list_name"}." = list_new(DOM_STRING);\n";
			$self->{"list_type"} = "DOMString";
		}
	}

	# Add the List/Collection to map
	$self->{"list_map"}->{$self->{"list_name"}} = $self->{"list_type"};

	# Reset the List/Collection member state
	$self->{"list_hasmem"} = 0;
	$self->{"list_name"} = "";
	$self->{"list_type"} = "";
	$self->{"list_num"} = 0;
}

sub generate_load {
	my ($self, $a) = @_;
	my %ats = %$a;
	my $doc = $ats{"var"};

	$test_index ++;
	# define the test file path, use HTML if there is, otherwise using XML
	# Attention: I intend to copy the test files to the program excuting dir
	print "\tconst char *test$test_index = \"$ats{'href'}.html\";\n\n";
	print "\t$doc = load_html(test$test_index, $ats{'willBeModified'});";
	print "\tif ($doc == NULL) {\n";
	$test_index ++;
	print "\t\tconst char *test$test_index = \"$ats{'href'}.xml\";\n\n";
	print "\t\t$doc = load_xml(test$test_index, $ats{'willBeModified'});\n";
	print "\t\tif ($doc == NULL)\n";
	print "\t\t\treturn 1;\n";
	print "\t\t}\n";
	print << "__EOF__";
	exp = dom_document_get_implementation($doc, &doc_impl);
	if (exp != DOM_NO_ERR)
		return exp;
__EOF__

	$self->addto_cleanup($doc);
}

sub generate_framework_statement {
	my ($self, $name, $ats) = @_;

	switch($name) {
		case "load" {
			$self->generate_load($ats);
		}

		case "assign" {
			my $var = $ats->{"var"};
			my $value = "0";
			if (exists $ats->{"value"}) {	
				$value = $ats->{"value"};
			}

			# Assign with strong-type-conversion, this is necessary in C. 
			# And we may need to do deep-copy in the future. FIXME
			my $type = type_to_ctype($self->{"var"}->{$var});
			print "$var = \($type\) $value;\n";
		}

		case "increment" {
			my $var = $ats->{"var"};
			my $value = $ats->{"value"};

			print "$var += $value;\n";
		}

		case "decrement" {
			my $var = $ats->{"var"};
			my $value = $ats->{"value"};

			print "$var -= $value;\n";
		}
		
		case "append" {
			my $col = $ats->{"collection"};
			my $obj = "";

			# God, the DTD said, there should be a "OBJ" attribute, but there may not!
			if (exists $ats->{"obj"}) {
				$obj = $ats->{"obj"};
			} else {
				$obj = $ats->{"item"}
			}

			if (not $self->{"var"}->{$col} =~ /^(List|Collection)/) {
				die "Append data to some non-list type!";
			}

			print "list_add($col, $obj);\n";
		}
		
		case [qw(plus subtract mult divide)] {
			my $var = $ats->{"var"};
			my $op1 = $ats->{"op1"};
			my $op2 = $ats->{"op2"};

			my %table = ("plus", "+", "subtract", "-", "mult", "*", "divide", "/");
			print "$var = $op1 $table{$name} $op2;\n";
		}

		case "comment" {
			print "\*";
			$self->{"inline_comment"} = 1;
		}

		case "implementation" {
			if (not exists $ats->{"obj"}) {
				my $var = $ats->{"var"};
				my $dstring = generate_domstring($self, $dom_feature);
				print "exp = dom_implregistry_get_dom_implementation($dstring, \&$var);\n";
				print "\tif (exp != DOM_NO_ERR) {\n";
				$self->cleanup_fail("\t\t");
				print "\t\treturn exp;\n\t}\n";
				last;
			}

			my $obj = $ats->{"obj"};
			my $var = $ats->{"var"};
			# Here we directly output the libDOM's get_implementation API
			print "\texp = dom_document_get_implementation($obj, \&$var);\n";
			print "\tif (exp != DOM_NO_ERR) {\n";
			$self->cleanup_fail("\t\t");
			print "\t\treturn exp;\n\t}\n";
		}

		# We deal with hasFeaturn and implementationAttribute in the generate_condition
		case "hasFeature" {
			die "No, never can be here!";
		}
		case "implementaionAttribute" {
			die "No, never can be here!";
		}
		
		# Here, we die because we did not implement other statements
		# We did not implement these statements, because there are no use of them in the W3C DOMTS now
		case [@framework_statement] {
			die "The statement \"$name\" is not implemented yet!";
		}

	}
}

sub complete_framework_statement {
	my ($self, $name) = @_;

	switch($name) {
		case "comment" {
			print "*/\n";
			$self->{"inline_comment"} = 0;
		}
	}
}

sub generate_interface {
	my ($self, $en, $a) = @_;
	my %ats = %$a;
	my $dd = $self->{dd};

	if (exists $ats{'interface'}) {
		# Firstly, test whether it is a DOM native interface
		if (exists $native_interface{$ats{'interface'}}) {
			if ($native_interface{$ats{'interface'}} eq "") {
				die "Unkown how to deal with $en of $ats{'interface'}";
			}

			return $native_interface{$ats{'interface'}}($self, $en, $a);
		}

		my $ns = $dd->find("/library/interface[\@name=\"$ats{'interface'}\"]/method[\@name=\"$en\"]");
		if ($ns->size() != 0) {
			my $node = $ns->get_node(1);
			$self->generate_method($en, $node, %ats);
		} else {
			my $ns = $dd->find("/library/interface[\@name=\"$ats{'interface'}\"]/attribute[\@name=\"$en\"]");
			if ($ns->size() != 0) {
				my $node = $ns->get_node(1);
				$self->generate_attribute_accessor($en, $node, %ats);
			}
		}
	} else {
		my $ns = $dd->find("/library/interface/method[\@name=\"$en\"]");
		if ($ns->size() != 0) {
			my $node = $ns->get_node(1);
			$self->generate_method($en, $node, %ats);
		} else {
			my $ns = $dd->find("/library/interface/attribute[\@name=\"$en\"]");
			if ($ns->size() != 0) {
				my $node = $ns->get_node(1);
				$self->generate_attribute_accessor($en, $node, %ats);
			} else {
				die "Oh, Can't find how to deal with the element $en\n";
			}
		}
	}
}

sub generate_method {
	my ($self, $en, $node, %ats) = @_;
	my $dd = $self->{dd};
	if (! exists $ats{'interface'}) {
		my $n = $node;
		while($n->getLocalName() ne "interface") {
			$n = $n->getParentNode();
		}
		$ats{'interface'} = $n->getAttribute("name");
	}

	$method = to_cmethod($ats{'interface'}, $en);
        my $cast = to_attribute_cast($ats{'interface'});
	my $ns = $dd->find("parameters/param", $node);
	my $params = "${cast}$ats{'obj'}";
	for ($count = 1; $count <= $ns->size; $count++) {
		my $n = $ns->get_node($count);
		my $p = $n->getAttribute("name");
		my $t = $n->getAttribute("type");

		# Change the raw string and the char * to dom_string
		if ($t eq "DOMString") {
			if ($ats{$p} =~ /^"/ or $self->{"var"}->{$ats{$p}} eq "char *") {
				$self->generate_domstring($ats{$p});
				$params = $params.", dstring$string_index";
				next;
			}
		}

		# For the case that the testcase did not provide the param, we just pass a NULL
		# Because we are in C, not like C++ which can overriden functions
		if (not exists $ats{$p}) {
			$params = $params.", NULL";
			next;
		}

		$params = $params.", $ats{$p}";
	}

	#$ns = $dd->find("returns", $node);
	#my $n = $ns->get_node(1);
	#my $t = $n->getAttribute("type");
	# declare the return value
	#my $tp = type_to_ctype($t);
	#print "\t$tp ret$ret_index;\n";
	my $unref = 0;
	my $temp_node = 0;
	if (exists $ats{'var'}) {
		# Add the bootstrap params
		if (exists $bootstrap_api{$method}) {
			if ($method eq "dom_implementation_create_document") {
				$params = $params.", myrealloc, NULL, NULL";
			} else {
				$params = $params.", myrealloc, NULL";
			}
		}
		# Deal with the situation like
		# 
		# dom_node_append_child(node, new_node, &node);
		# 
		# Here, we should import a tempNode, and change this expression to
		#
		# dom_node *tnode1 = NULL;
		# dom_node_append_child(node, new_node, &tnode1);
		# dom_node_unref(node);
		# node = tnode1;
		#
		# Over.
		if ($ats{'obj'} eq $ats{'var'}) {
			my $t = type_to_ctype($self->{'var'}->{$ats{'var'}});
			$tnode_index ++;
			print "$t tnode$tnode_index = NULL;";
			$params = $params.", \&tnode$tnode_index";
			# The ats{'obj'} must have been added to cleanup stack 
			$unref = 1;
			# Indicate that we have created a temp node
			$temp_node = 1;
		} else {
			$params = $params.", (void *) \&$ats{'var'}";
			$unref = $self->param_unref($ats{'var'});
		}
	}

	print "\texp = $method($params);\n";

	if ($self->{'exception'} eq 0) {
		print << "__EOF__";
	if (exp != DOM_NO_ERR) {
	fprintf(stderr, "Exception raised from %s\\n", "$method");
__EOF__

		$self->cleanup_fail("\t\t");
		print << "__EOF__";
		return exp;
	}
__EOF__
	}

	if (exists $ats{'var'} and $unref eq 0) {
		$self->addto_cleanup($ats{'var'});
	}

	if ($temp_node eq 1) {
		my $t = $self->{'var'}->{$ats{'var'}};
		if (not exists $no_unref{$t}) {
			my $prefix = "dom_node";
			if (exists $unref_prefix{$t}) {
				$prefix = $unref_prefix{$t};
			}
			print $prefix."_unref(".$ats{'obj'}.");\n";
		}
		print "$ats{'var'} = tnode$tnode_index;";
	}
}

sub generate_attribute_accessor {
	my ($self, $en, $node, %ats) = @_;

	if (defined($ats{'var'})) {
		generate_attribute_fetcher(@_);
	} else {
		if (defined($ats{'value'})) {
			generate_attribute_setter(@_);
		}
	}
}

sub generate_attribute_fetcher {
	my ($self, $en, $node, %ats) = @_;
	my $dd = $self->{dd};
	if (! exists $ats{'interface'}) {
		my $n = $node;
		while($n->getLocalName() ne "interface") {
			$n = $n->getParentNode();
		}
		$ats{'interface'} = $n->getAttribute("name");
	}

	my $fetcher = to_attribute_fetcher($ats{'interface'}, "$en");
        my $cast = to_attribute_cast($ats{'interface'});
	my $unref = 0;
	my $temp_node = 0;
	# Deal with the situation like
	# 
	# dom_node_get_next_sibling(child, &child);
	# 
	# Here, we should import a tempNode, and change this expression to
	#
	# dom_node *tnode1 = NULL;
	# dom_node_get_next_sibling(child, &tnode1);
	# dom_node_unref(child);
	# child = tnode1;
	#
	# Over.
	if ($ats{'obj'} eq $ats{'var'}) {
		my $t = type_to_ctype($self->{'var'}->{$ats{'var'}});
		$tnode_index ++;
		print "\t$t tnode$tnode_index = NULL;\n";
		print "\texp = $fetcher(${cast}$ats{'obj'}, \&tnode$tnode_index);\n";
		# The ats{'obj'} must have been added to cleanup stack 
		$unref = 1;
		# Indicate that we have created a temp node
		$temp_node = 1;
	} else {
		$unref = $self->param_unref($ats{'var'});
		print "\texp = $fetcher(${cast}$ats{'obj'}, \&$ats{'var'});\n";
	}


	if ($self->{'exception'} eq 0) {
		print << "__EOF__";
	if (exp != DOM_NO_ERR) {
		fprintf(stderr, "Exception raised when fetch attribute %s", "$en");
__EOF__
		$self->cleanup_fail("\t\t");
		print << "__EOF__";
		return exp;
	}
__EOF__
	}

	if ($temp_node eq 1) {
		my $t = $self->{'var'}->{$ats{'var'}};
		if (not exists $no_unref{$t}) {
			my $prefix = "dom_node";
			if (exists $unref_prefix{$t}) {
				$prefix = $unref_prefix{$t};
			}
			print $prefix."_unref(".$ats{'obj'}.");\n";
		}
		print "$ats{'var'} = tnode$tnode_index;";
	}

	if ($unref eq 0) {
		$self->addto_cleanup($ats{'var'});
	}
}

sub generate_attribute_setter {
	my ($self, $en, $node, %ats) = @_;
	my $dd = $self->{dd};
	if (! exists $ats{'interface'}) {
		my $n = $node;
		while($n->getLocalName() ne "interface") {
			$n = $n->getParentNode();
		}
		$ats{'interface'} = $n->getAttribute("name");
	}

	my $setter = to_attribute_setter($ats{'interface'}, "$en");
	my $param = "$ats{'obj'}";

	# For DOMString, we should deal specially
	my $lp = $ats{'value'};
	if ($node->getAttribute("type") eq "DOMString") {
		if ($ats{'value'} =~ /^"/ or $self->{"var"}->{$ats{'value'}} eq "char *") {
			$lp = $self->generate_domstring($ats{'value'});
		}
	}

	$param = $param.", $lp";

	print "exp = $setter($param);";

	if ($self->{'exception'} eq 0) {
		print << "__EOF__";
		if (exp != DOM_NO_ERR) {
			fprintf(stderr, "Exception raised when fetch attribute %s", "$en");
__EOF__
		$self->cleanup_fail("\t\t");
		print << "__EOF__";
			return exp;
		}
__EOF__
	}

}


sub generate_condition {
	my ($self, $name, $ats) = @_;

	# If we are in nested or/and/xor/not, we should put a operator before test
	my @array = @{$self->{condition_stack}};
	if ($#array ge 0) {
		switch ($array[-1]) {
			case "xor" {
				print " ^ ";
			}
			case "or" {
				print " || ";
			}
			case "and" {
				print " && ";
			}
			# It is the indicator, just pop it.
			case "new" {
				pop(@{$self->{condition_stack}});
			}
		}
	}

	switch ($name) {
		case [qw(less lessOrEquals greater greaterOrEquals)] {
			my $actual = $ats->{actual};
			my $expected = $ats->{expected};
			my $method = $name;
			$method =~ s/[A-Z]/_$&/g;
			$method = lc $method;
			print "$method($expected, $actual)";
		}

		case "same" {
			my $actual = $ats->{actual};
			my $expected = $ats->{expected};
			my $func = $self->find_override("is_same", $actual, $expected);
			print "$func($expected, $actual)";
		}

		case [qw(equals notEquals)]{
			my $actual = $ats->{actual};
			my $expected = $ats->{expected};
			my $ig;
			if (exists $ats->{ignoreCase}){
				$ig = $ats->{ignoreCase};
			} else {
				$ig = "false";
			}
			$ig = adjust_ignore($ig);

			my $func = $self->find_override("is_equals", $actual, $expected);
			if ($name =~ /not/i){
				print "(false == $func($expected, $actual, $ig))";
			} else {
				print "$func($expected, $actual, $ig)";
			}
		}

		case [qw(isNull notNull)]{
			my $obj = $ats->{obj};
			if ($name =~ /not/i) {
				print "(false == is_null($obj))";
			} else {
				print "is_null($obj)";
			}
		}

		case "isTrue" {
			my $value = $ats->{value};
			print "is_true($value)";
		}

		case "isFalse" {
			my $value = $ats->{value};
			print "(false == is_true($value))";
		}

		case "hasSize" {
			my $obj = $ats->{obj};
			my $size = $ats->{expected};
			my $func = $self->find_override("is_size", $obj, $size);
			print "$func($size, $obj)";
		}

		case "contentType" {
			my $type = $ats->{type};
			print "is_contenttype(\"$type\")";
		}

		case "instanceOf" {
			my $obj = $ats->{obj};
			my $type = $ats->{type};
			print "instanceOf(\"$type\", $obj)";
		}

		case "hasFeature" {
			if (exists $ats->{var}) {
				$self->generate_interface($name, $ats);
			} else {
				my $feature = $ats->{feature};
				if (not ($feature =~ /^"/)) {
					$feature = '"'.$feature.'"';
				}
				my $version = "NULL";
				if (exists $ats->{version}) {
					$version = $ats->{version};
					if (not ($version =~ /^"/)) {
						$version = '"'.$version.'"';
					}
					
				}

				if ($self->{context}->[-2] ne "condition") {
					# we are not in a %condition place, so we must be a statement
					# we change this to assert
					# print "assert(has_feature($feature, $version));\n"
					# do nothing if we are not in condition.
				} else {
					print "has_feature($feature, $version)";
				}
			}
		}

		case "implementationAttribute" {
			my $value = $ats->{value};
			my $name = $ats->{name};
			
			if ($self->{context}->[-2] ne "condition") {
				# print "assert(implementation_attribute(\"$name\", $value));";
				# Do nothing, and the same with hasFeature, this means we will
				# run all test cases now and try to get a result whether we support
				# such feature.
			} else {
				print "implementation_attribute(\"$name\", $value)";
			}
		}

		case [qw(and or xor)] {
			push(@{$self->{condition_stack}}, $name);
			push(@{$self->{condition_stack}}, "new");
			print "(";
		}

		case "not" {
			push(@{$self->{condition_stack}}, $name);
			print "(false == ";
		}
	}

}

sub complete_condition {
	my ($self, $name) = @_;

	if ($name =~ /^(xor|or|and)$/i) {
		print ")";
		my $top = pop(@{$self->{condition_stack}});
		die "Condition stack error! $top != $name" if $top ne $name;
	}

	if ($name eq "not") {
		my $top = pop(@{$self->{condition_stack}});
				die "Condition stack error! $top != $name" if $top ne $name;
		print ")";
	}

	# we deal with the situation that the %condition is in a control statement such as
	# <if> or <while>, and we should start a new '{' block here
	if ($self->{context}->[-1] eq "condition") {
		print ") {\n";
		pop(@{$self->{context}});
	}
}

sub generate_assertion {
	my ($self, $name, $ats) = @_;

	print "\tassert(";
	switch($name){
		# Only assertTrue & assertFalse can have nested %conditions
		case [qw(assertTrue assertFalse assertNull)] {
			my $n = $name;
			$n =~ s/assert/is/g;
			if (exists $ats->{actual}){
				my $ta = { value => $ats->{actual}, obj => $ats->{actual}};
				$self->generate_condition($n,$ta);
			}
		}

		case [qw(assertNotNull assertEquals assertNotEquals assertSame)] {
			my $n = $name;
			$n =~ s/assert//g;
			$n = lcfirst $n;
			if (exists $ats->{actual}){
				my $ta = { 	
						actual => $ats->{actual},
						value => $ats->{actual}, 
						obj => $ats->{actual},
						expected => $ats->{expected},
						ignoreCase => $ats->{ignoreCase},
						type => $ats->{type},
					 };
				$self->generate_condition($n,$ta);
			}
		}

		case "assertInstanceOf" {
			my $obj = $ats->{obj};
			my $type = $ats->{type};
			print "is_instanceof(\"$type\", $obj)";
		}

		case "assertSize" {
			my $n = $name;
			$n =~ s/assert/has/;
			if (exists $ats->{collection}){
				my $ta = { obj => $ats->{collection}, expected => $ats->{size}};
				$self->generate_condition($n,$ta);
			}
		}
	
		case "assertEventCount" {
			#todo
		}
		
		case "assertURIEquals" {
			my $actual = $ats->{actual};
			my ($scheme, $path, $host, $file, $name, $query, $fragment, $isAbsolute) = qw(NULL NULL NULL NULL NULL NULL NULL NULL);
			if (exists $ats->{scheme}) {
				$scheme = $ats->{scheme};
			}
			if (exists $ats->{path}) {
				$path = $ats->{path};
			}
			if (exists $ats->{host}) {
				$host = $ats->{host};
			}
			if (exists $ats->{file}) {
				$file = $ats->{file};
			}
			if (exists $ats->{name}) {
				$name = $ats->{name};
			}
			if (exists $ats->{query}) {
				$query = $ats->{query};
			}
			if (exists $ats->{fragment}) {
				$fragment = $ats->{fragment};
			}
			if (exists $ats->{isAbsolute}) {
				$isAbsolute = $ats->{isAbsolute};
			}

			print "is_uri_equals($scheme, $path, $host, $file, $name, $query, $fragment, $isAbsolute, $actual)"
		}
	}

}

sub complete_assertion {
	my ($self, $name) = @_;

	print ");\n";
}

sub generate_control_statement {
	my ($self, $name, $ats) = @_;

	switch($name) {
		case "if" {
			print "\tif(";
			push(@{$self->{"context"}}, "condition");
		}

		case "else" {
			$self->cleanup_block_domstring();
			print "\t} else {";
		}

		case "while" {
			print "\twhile (";
			push(@{$self->{"context"}}, "condition");
		}

		case "for-each" {
			# Detect what is the collection type, if it is "string", we
			# should also do some conversion work
			my $coll = $ats->{"collection"};
			# The default member type is dom_node
			my $type = "dom_node *";
			if (exists $self->{"list_map"}->{$coll}) {
				$type = $self->{"list_map"}->{$coll};
			}

			# Find the member variable, if it is not declared before, declare it firstly
			my $member = $ats->{"member"};
			if (not exists $self->{"var"}->{$member}) {
				print "$type  $member;\n";
				# Add the new variable to the {var} map
				$self->{"var"}->{"$member"} = $type;
			}

			# Now the member is conformed to be declared
			if ($self->{"var"}->{$coll} =~ /^(List|Collection)$/) {
				# The element in the list is not equal with the member object
				# For now, there is only one case for this, it is "char *" <=> "DOMString"
				my $conversion = 0;
				if ($self->{"var"}->{"$member"} ne $type) {
					if ($self->{"var"}->{"$member"} eq "DOMString") {
						if ($type eq "char *") {
							$conversion = 1;
						}
					}
				}

				$iterator_index++;
				print "unsigned int iterator$iterator_index = 0;";
				if ($conversion eq 1) {
					print "char *tstring$temp_index = NULL;";
				}
				print "foreach_initialise_list($coll, \&iterator$iterator_index);\n";
				print "while(get_next_list($coll, \&iterator$iterator_index, ";
				if ($conversion eq 1) {
					print "\&tstring$temp_index)) {\n";
					print "exp = dom_string_create((const uint8_t *)tstring$temp_index,";
					print "strlen(tstring$temp_index), &$member);\n";
					print "if (exp != DOM_NO_ERR) {\n";
					print "\t\tfprintf(stderr, \"Can't create DOMString\\n\");";
					$self->cleanup_fail("\t\t");
					print "\t\treturn exp;\n\t}\n";
					$temp_index ++;
				} else {
					print "\&$member)) {\n";
				}
			}

			if ($self->{"var"}->{$coll} eq "NodeList") {
				$iterator_index++;
				print "unsigned int iterator$iterator_index = 0;";
				print "foreach_initialise_domnodelist($coll, \&iterator$iterator_index);\n";
				print "while(get_next_domnodelist($coll, \&iterator$iterator_index, \&$member)) {\n";
			}

			if ($self->{"var"}->{$coll} eq "NamedNodeMap") {
				$iterator_index++;
				print "unsigned int iterator$iterator_index = 0;";
				print "foreach_initialise_domnamednodemap($coll, \&iterator$iterator_index);\n";
				print "while(get_next_domnamednodemap($coll, \&iterator$iterator_index, \&$member)) {\n";
			}

			if ($self->{"var"}->{$coll} eq "HTMLCollection") {
				$iterator_index++;
				print "unsigned int iterator$iterator_index = 0;";
				print "foreach_initialise_domhtmlcollection($coll, \&iterator$iterator_index);\n";
				print "while(get_next_domhtmlcollection($coll, \&iterator$iterator_index, \&$member)) {\n";
			}
		}
	}

	# Firstly, we enter a new block, so push a "b" into the string_unref list
	push(@{$self->{"string_unref"}}, "b");
}

sub complete_control_statement {
	my ($self, $name) = @_;

	# Note: we only print a '}' when <if> element ended but not <else> 
	# The reason is that there may be no <else> element in <if> and 
	# we when there is an <else> element, it must nested in <if>. ^_^
	switch($name) {
		case [qw(if while for-each)] {
			# Firstly, we should cleanup the dom_string in this block
			$self->cleanup_block_domstring();

			print "}\n";
		}
	}
}


###############################################################################
#
# The helper functions
#
sub generate_domstring {
	my ($self, $str) = @_;
	$string_index = $string_index + 1;

	print << "__EOF__";
	const char *string$string_index = $str;
	dom_string *dstring$string_index;
	exp = dom_string_create((const uint8_t *)string$string_index,
			strlen(string$string_index), &dstring$string_index);
	if (exp != DOM_NO_ERR) {
		fprintf(stderr, "Can't create DOMString\\n");
__EOF__
	$self->cleanup_fail("\t\t");
	print << "__EOF__";
		return exp;
	}

__EOF__

	push(@{$self->{string_unref}}, "$string_index");

	return "dstring$string_index";
}

sub cleanup_domstring {
	my ($self, $indent) = @_;

	for (my $i = 0; $i <= $#{$self->{string_unref}}; $i++) {
		if ($self->{string_unref}->[$i] ne "b") {
			print $indent."dom_string_unref(dstring$self->{string_unref}->[$i]);\n";
		}
	}
}

sub cleanup_block_domstring {
	my $self = shift;

	while ((my $num = pop(@{$self->{string_unref}})) ne "b" and $#{$self->{string_unref}} ne -1) {
		print "dom_string_unref(dstring$num);\n";
	}
}

sub type_to_ctype {
	my $type = shift;

	if (exists $special_type{$type}) {
		return $special_type{$type};
	}

	# If the type is not specially treated, we can transform it by rules
	if ($type =~ m/^HTML/) {
		# Don't deal with this now
		return "";
	}

	# The core module comes here
	$type =~ s/[A-Z]/_$&/g;
	$type = lc $type;

	# For events module
	$type =~ s/_u_i_/_ui_/g;

	return "dom".$type." *";
}

sub to_cmethod {
	my ($type, $m) = @_;
	my $prefix = get_prefix($type);
	my $ret;

	if (exists $special_method{$m}) {
		$ret = $prefix."_".$special_method{$m};
	} else {
		$m =~ s/[A-Z]/_$&/g;
		$m = lc $m;
		$ret = $prefix."_".$m;
	}

	$ret =~ s/h_t_m_l/html/;
	$ret =~ s/c_d_a_t_a/cdata/;
	$ret =~ s/_n_s$/_ns/;
	# For DOMUIEvent
	$ret =~ s/_u_i_/_ui_/;
	# For initEvent
	$ret =~ s/init_event/init/;
	return $ret;
}

sub to_attribute_fetcher {
	return to_attribute_accessor(@_, "get");
}

sub to_attribute_setter {
	return to_attribute_accessor(@_, "set");
}

sub to_attribute_accessor {
	my ($type, $af, $accessor) = @_;
	my $prefix = get_prefix($type);
	my $ret;

	if (exists $special_attribute{$af}) {
		$ret = $prefix."_".$accessor."_".$special_attribute{$af};
	} else {
		$af =~ s/[A-Z]/_$&/g;
		$af = lc $af;
		$ret = $prefix."_".$accessor."_".$af;
	}

	$ret =~ s/h_t_m_l/html/;
	return $ret;
}

sub to_attribute_cast {
	my $type = shift;
        my $ret = get_prefix($type);
        $ret =~ s/h_t_m_l/html/;
        return "(${ret} *)";
}

sub get_prefix {
	my $type = shift;

	if (exists $special_prefix{$type}) {
		$prefix = $special_prefix{$type};
	} else {
		$type =~ s/[A-Z]/_$&/g;
		$prefix = lc $type;
		$prefix = "dom".$prefix;
	}
	return $prefix;
}

# This function remain unsed
sub get_suffix {
	my $type = shift;
	my $suffix = "default";

	if (exists $override_suffix{$type}) {
		$suffix = $override_suffix{$type};
	} else {
		$type =~ s/[A-Z]/_$&/g;
		$suffix = lc $type;
		$suffix = "dom".$suffix;
	}
	return $suffix;
}

#asserttions sometimes can contain sub-statements according the DTD. Like
#<assertEquals ..>
# <stat1 />
# <stat2 />
#</assertEquals>
#
# And assertion can contains assertions too! So, I use the assertion_stack
# to deal:
#
# when we encounter an assertion, we push $assertionName, "end", "start" to 
# the stack, and when we encounter a statement, we examine the stack to see 
# the top element, if it is:
#
# 1. "start", then we are in sub-statement of that assertion, and this is the
#	the first sub-statement, so we should print a if (condtion==true) {, before
#	print the real statement.
# 2. "end", then we are in sub-statement of that assertion, and we are not the 
#	first one, just print the statement.
#
# But after searching the whole testcases, I found no use of sub-statements of assertions.
# So, this function left unsed!

sub end_half_assertion {
	my ($self, $name) = @_;

	my $top = pop(@{$self->{assertion_stack}});
	if ($top eq "end") {
		print "$self->{indent}"."}\n";
	} else {
		if ($top eq "start") {
			pop(@{$self->{assertion_stack}});
			pop(@{$self->{assertion_stack}});
		}
	}

	pop(@{$self->{assertion_stack}});
}
### Enclose an unsed function
##############################################################################################


sub cleanup_domvar {
	my ($self, $indent) = @_;

	my $str = join($indent, reverse @{$self->{unref}});
	print $indent.$str."\n";
}

sub cleanup_fail {
	my ($self, $indent) = @_;

	$self->cleanup_domstring($indent);
	$self->cleanup_domvar($indent);
}

sub cleanup {
	my $self = shift;

	print "\n\n";
	$self->cleanup_domstring("\t");
	$self->cleanup_domvar("\t");
        print "\n\tprintf(\"PASS\");\n";
	print "\n\treturn 0;\n";
	print "\n\}\n";
}

sub addto_cleanup {
	my ($self, $var) = @_;

	my $type = $self->{'var'}->{$var};
	if (not exists $no_unref{$type}) {
		my $prefix = "dom_node";
		if (exists $unref_prefix{$type}) {
			$prefix = $unref_prefix{$type};
		}
		push(@{$self->{unref}}, $prefix."_unref(".$var.");\n");
	}
}

sub adjust_ignore {
	my $ig = shift;

	if ($ig eq "auto"){
		return "true";
	}
	return $ig;
}

sub find_override {
	my ($self, $func, $var, $expected) = @_;
	my $vn = $self->{var}->{$var};

	# Deal with string types
	if ($expected eq "DOMString") {
		return $func."_domstring";
	} else {
		if ($expected =~ /^\"/ or $self->{"var"}->{$expected} eq "char *") {
			return $func."_string";
		}
	}

	if (exists $override_suffix{$vn}) {
		$func = $func."_".$override_suffix{$vn}
	}
	return $func;
}

sub param_unref {
	my ($self, $var) = @_;

	my $type = $self->{'var'}->{$var};
	if (not exists $no_unref{$type}) {
		my $prefix = "dom_node";
		if (exists $unref_prefix{$type}) {
			$prefix = $unref_prefix{$type};
		}
		print "\tif ($var != NULL) {\n";
		print "\t\t" . $prefix."_unref(".$var.");\n";
		print "\t\t$var = NULL;\n";
		print "\t}\n";
	}

	foreach my $item (@{$self->{unref}}) {
		$item =~ m/.*\((.*)\).*/;
		if ($var eq $1) {
			return 1;
		}
	}

	foreach my $item (@{$self->{string_unref}}) {
		if ($var eq $item) {
			return 1;
		}
	}

	return 0;
}

sub generate_domstring_interface {
	my ($self, $en, $a) = @_;

	switch ($en) {
		case "length" {
			print "$a->{'var'} = dom_string_length($a->{'obj'});";
		}

		else {
			die "Can't generate method/attribute $en for DOMString";
		}
	}
}

1;