#!/usr/bin/perl -w
# 
# Copyright (C) 2004 Naba Kumar  <naba@gnome.org>
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU Library General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

use strict;
use Data::Dumper;

if (@ARGV != 1)
{
	die "Usage: perl anjuta-idl-compiler.pl module_name";
}

## Types starting with prefix mentioned in
## @known_type_prefixes array are automatically assumed to be GObject derived
## class and their type and assertion checks are determined based on that.
## This automation is skipped if the type is found in %not_classes hash table.
my $known_type_prefixes = [
	"Gdk",
	"Gtk",
	"Gnome",
	"Anjuta",
	"IAnjuta",
];

## Add your types which are not classes despite starting with above prefixes
my $not_classes = {
	"GtkTreeIter" => 1,
};

## Additional non-standard type mappings.
my $type_map = {
	"void" => {
		"gtype" => "G_TYPE_NONE",
	},
	"gchar*" => {
		"gtype" => "G_TYPE_STRING",
		"assert" => "__arg__ != NULL",
		"fail_return" => "NULL"
	},
	"constgchar*" => {
		"gtype" => "G_TYPE_STRING",
		"assert" => "__arg__ != NULL",
		"fail_return" => "NULL"
	},
	"gchar" => {
		"gtype" => "G_TYPE_CHAR",
		"fail_return" => "0"
	},
	"gint" => {
		"gtype" => "G_TYPE_INT",
		"fail_return" => "-1"
	},
	"gboolean" => {
		"gtype" => "G_TYPE_BOOLEAN",
		"fail_return" => "FALSE"
	},
	"GInterface*" => {
		"gtype" => "G_TYPE_INTERFACE",
		"assert" => "G_IS_INTERFACE (__arg__)",
		"fail_return" => "NULL"
	},
	## G_TYPE_CHAR
	"guchar*" => {
		"gtype" => "G_TYPE_UCHAR",
		"assert" => "__arg__ != NULL",
		"fail_return" => "NULL"
	},
	"constguchar*" => {
		"gtype" => "G_TYPE_UCHAR",
		"assert" => "__arg__ != NULL",
		"fail_return" => "NULL"
	},
	"guint" => {
		"gtype" => "G_TYPE_UINT",
		"fail_return" => "0"
	},
	"glong" => {
		"gtype" => "G_TYPE_LONG",
		"fail_return" => "-1"
	},
	"gulong" => {
		"gtype" => "G_TYPE_ULONG",
		"fail_return" => "0"
	},
	"gint64" => {
		"gtype" => "G_TYPE_INT64",
		"fail_return" => "-1"
	},
	"guint64" => {
		"gtype" => "G_TYPE_UINT64",
		"fail_return" => "0"
	},
	## G_TYPE_ENUM
	## G_TYPE_FLAGS
	"gfloat" => {
		"gtype" => "G_TYPE_FLOAT",
		"fail_return" => "0"
	},
	"gdouble" => {
		"gtype" => "G_TYPE_DOUBLE",
		"fail_return" => "0"
	},
	"gpointer" => {
		"gtype" => "G_TYPE_POINTER",
		"assert" => "__arg__ != NULL",
		"fail_return" => "NULL"
	},
	"GValue*" => {
		"gtype" => "G_TYPE_BOXED",
		"assert" => "G_IS_VALUE(__arg__)",
		"fail_return" => "NULL"
	},
	## G_TYPE_PARAM
	"GObject*" => {
		"gtype" => "G_TYPE_OBJECT",
		"assert" => "G_IS_OBJECT(__arg__)",
		"fail_return" => "NULL"
	}
};

my $module_name = $ARGV[0];
my $idl_file = "$module_name.idl";
open (INFILE, "<$idl_file")
	or die "Can not open IDL file for reading";

my %marshallers = ();
my @global_includes;
my @class_includes;
my %class_privates = ();
my @header_files;
my @source_files;
my $parent_class = "";
my $current_class = "";
my @classes;
my @level = ();
my $inside_block = 0;
my $inside_comment = 0;
my $comments = "";
my $line = "";
my $linenum = 1;
my $data_hr = {};
my @collector = ();
my $struct = "";
my $enum = "";
my $typedef = "";

while ($line = <INFILE>)
{
	if (is_comment_begin($line)) {
		if (current_level(@level) ne "comment") {
			push @level, "comment";
		}
	}
	if (current_level(@level) eq "comment")
	{
		$comments .= $line;
		if (is_comment_end($line)) {
			splice @level, @level - 1, 1;
		}
		$linenum++;
		next;
	}
	chomp ($line);
	## Remove comments
	$line =~ s/\/\/.*$//;
	$line =~ s/^\s+//;
	$line =~ s/\s+$//;
	if ($line =~ /^\s*$/)
	{
 		$linenum++;
		next;
	}
	
	if ($line =~ /^\#include/)
	{
		if (@level <= 0)
		{
			push @global_includes, $line;
		}
		else 
		{
			my $includes_lr = $class_includes[@class_includes-1];
			push @$includes_lr, $line;
		}
		next;
	}
	if (is_block_begin($line))
	{
		$linenum++;
		next;
	}
	
	my $class;
	if (is_interface($line, \$class))
	{
		push @level, "interface";
		if ($current_class ne "")
		{
			$parent_class = $current_class;
		}
		push (@class_includes, []);
		push (@classes, $current_class);
		$current_class = $class;
		my $comments_in = get_comments();
		compile_class($data_hr, $parent_class, $comments_in, $current_class);
		$linenum++;
		next;
	}
	elsif (is_struct($line, \$class))
	{
		push @level, "struct";
		$struct = $class;
		$linenum++;
		next;
	}
	elsif (is_enum($line, \$class))
	{
		push @level, "enum";
		$enum = $class;
		$linenum++;
		next;
	}
	elsif (is_typedef($line, \$typedef))
	{
		die "Parse error at $idl_file:$linenum: typedefs should only be in interface"
			if (current_level(@level) ne "interface");
		die "Parse error at $idl_file:$linenum: Class name expected"
			if ($current_class eq "");
		my $comments_in = get_comments();
		compile_typedef($data_hr, $current_class, $comments_in, $typedef);
		$typedef = "";
		$linenum++;
		next;
	}

	my $method_hr = {};
	if (is_method($line, $method_hr)) {
		die "Parse error at $idl_file:$linenum: Methods should only be in interface"
			if (current_level(@level) ne "interface");
		die "Parse error at $idl_file:$linenum: Class name expected"
			if ($current_class eq "");
		my $comments_in = get_comments();
		compile_method($data_hr, $parent_class, $current_class, $comments_in, $method_hr);
		$linenum++;
		next;
	}
	if (is_block_end($line))
	{
		if (current_level(@level) eq "interface")
		{
			compile_inclues($data_hr, $current_class);
			splice @class_includes, @class_includes - 1, 1;
			$current_class = "";
			$parent_class = "";
			if (@classes > 0)
			{
				$current_class = splice @classes, @classes - 1, 1;
			}
			if (@classes > 0)
			{
				$parent_class = $classes[@classes -1];
			}
			$linenum++;
		}
		elsif (current_level(@level) eq "struct")
		{
			my $comments_in = get_comments();
			$not_classes->{"$current_class$struct"} = "1";
			compile_struct($data_hr, $current_class, $struct,
						   $comments_in, @collector);
			@collector = ();
			$struct = "";
			$linenum++;
		}
		elsif (current_level(@level) eq "enum")
		{
			my $comments_in = get_comments();
			$not_classes->{"$current_class$enum"} = "1";
			compile_enum($data_hr, $current_class, $enum,
						 $comments_in, @collector);
			@collector = ();
			$enum = "";
			$linenum++;
		}
		splice @level, @level - 1, 1;
		next;
	}
	die "Parse error at $idl_file:$linenum: Type name or method expected"
		if (current_level(@level) ne "struct" and
			current_level(@level) ne "enum");
	push @collector, $line;
	$linenum++;
}

## print Dumper($data_hr);
## print Dumper(\%class_privates);
## print Dumper($not_classes);

generate_files($data_hr);

sub is_comment_begin
{
	my ($line) = @_;
	if ($line =~ /\/\*/)
	{
		## print "Comment begin\n";
		return 1;
	}
	return 0;
}

sub is_comment_end
{
	my ($line) = @_;
	if ($line =~ /\*\//)
	{
		## print "Block End\n";
		return 1;
	}
	return 0;
}

sub is_block_begin
{
	my ($line) = @_;
	if ($line =~ /^\s*\{\s*$/)
	{
		## print "Block begin\n";
		return 1;
	}
	return 0;
}

sub is_block_end
{
	my ($line) = @_;
	if ($line =~ /^\s*\}\s*$/)
	{
		## print "Block End\n";
		return 1;
	}
	return 0;
}

sub is_interface
{
	my ($line, $class_ref) = @_;
	if ($line =~ /^\s*interface\s*([\w|_]+)\s*$/)
	{
		$$class_ref = $1;
		## print "Interface: $line\n";
		return 1;
	}
	return 0;
}

sub is_enum
{
	my ($line, $class_ref) = @_;
	if ($line =~ /^\s*enum\s*([\w\d|_]+)\s*$/)
	{
		my $enum_name = $1;
		add_class_private ($current_class, $enum_name);
		$$class_ref = $enum_name;
		## print "Enum: $line\n";
		return 1;
	}
	return 0;
}

sub is_struct
{
	my ($line, $class_ref) = @_;
	if ($line =~ /^\s*struct\s*([\w\d|_]+)\s*$/)
	{
		my $struct_name = $1;
		$$class_ref = $struct_name;
		add_class_private ($current_class, $struct_name);
		## print "Struct: $line\n";
		return 1;
	}
	return 0;
}

sub is_typedef
{
	my ($line, $typedef_ref) = @_;
	if ($line =~ /^\s*typedef\s*/)
	{
		## Check if it is variable typedef and grab the typedef name.
		if ($line =~ /([\w_][\w\d_]+)\s*;\s*$/)
		{
			add_class_private ($current_class, $1);
		}
		## Check if it is function typedef and grab the typedef name.
		elsif ($line =~ /\(\s*\*([\w_][\w\d_]+)\s*\)/)
		{
			add_class_private ($current_class, $1);
		}
		$$typedef_ref = $line;
		## print "Typedef: $line\n";
		return 1;
	}
	return 0;
}

sub is_method
{
	my ($line, $method_hr) = @_;
	if ($line =~ s/([\w_][\w\d_]*)\s*\((.*)\)\s*\;\s*$//)
	{
		my $function = $1;
		my $args = $2;
		my $rettype = $line;
		$function =~ s/^\s+//;
		$function =~ s/\s+$//;
		$args =~ s/^\s+//;
		$args =~ s/\s+$//;
		$rettype =~ s/^\s+//;
		$rettype =~ s/\s+$//;
		if ($rettype =~ s/\:\:$//) {
			$function = "::".$function;
		}
		$rettype =~ s/\s+$//;
		
		$method_hr->{'function'} = $function;
		$method_hr->{'rettype'} = $rettype;
		$method_hr->{'args'} = $args;
		## print "Function: $line\n";
		return 1;
	}
	return 0;
}

sub normalize_namespace
{
	my ($current_class, $text) = @_;
	
	my $iter_class = $current_class;
	while (1)
	{
		if (defined ($class_privates{$iter_class}))
		{
			foreach my $p (@{$class_privates{$iter_class}})
			{
				$text =~ s/\b$p\b/$iter_class$p/g;
			}
		}
		if (defined ($data_hr) &&
			defined ($data_hr->{$iter_class}) &&
			defined ($data_hr->{$iter_class}->{"__parent"}))
		{
			$iter_class = $data_hr->{$iter_class}->{"__parent"};
		}
		else
		{
			last;
		}
	}
	return $text;
}

sub current_level
{
	## @l = @_;
	## return splice @l, @l - 1, 1;
	return $_[@_-1] if (@_ > 0);
	return "";
}

sub get_comments
{
	my $comments_in = $comments;
	if ($comments ne "")
	{
		$comments = "";
	}
	$comments_in =~ s/^\t+//mg;
	return $comments_in;
}

sub add_class_private
{
	my ($class, $type) = @_;
	if (!defined ($class_privates{$class}))
	{
		$class_privates{$class} = [];
	}
	push (@{$class_privates{$class}}, $type);
}

sub is_class_private
{
	my ($class, $type) = @_;
	if (defined ($class_privates{$class}))
	{
		foreach my $p (@{$class_privates{$class}})
		{
			if ($p eq $type)
			{
				return 1;
			}
		}
	}
	return 0;
}

sub compile_class
{
	my ($data_hr, $parent, $comments, $class) = @_;
	die "Error $idl_file:$linenum: Class $class already exist"
		if (ref($data_hr->{$class}) eq 'HASH');
	$data_hr->{$class} = {};
	my $class_ref = $data_hr->{$class};
	
	$class_ref->{'__parent'} = $parent;
	$class_ref->{'__comments'} = $comments;
}

sub compile_method
{
	my ($data_hr, $parent, $class, $comments, $method_hr) = @_;
	die "Error $idl_file:$linenum: Class $class doesn't exist"
		if (ref($data_hr->{$class}) ne 'HASH');
	my $class_hr = $data_hr->{$class};
	my $method = $method_hr->{'function'};
	
	die "Error $idl_file:$linenum: Method $method already defined for class $class."
		if (ref($class_hr->{$method}) eq 'HASH');
	
	$method_hr->{'__comments'} = $comments;
	$class_hr->{$method} = $method_hr;
}

sub compile_inclues
{
	my ($data_hr, $class) = @_;
	die "Error $idl_file:$linenum: Class $class doesn't exist"
		if (ref($data_hr->{$class}) ne 'HASH');
	my $class_hr = $data_hr->{$class};
	
	if (ref($class_hr->{"__include"}) ne 'ARRAY')
	{
		my @includes;
		foreach my $inc (@global_includes)
		{
			## Normalize includes.
			$inc =~ s/\"(.+)\"/\<$module_name\/interfaces\/$1\>/;
			push @includes, $inc;
		}
		my $class_incs_lr = $class_includes[@class_includes-1];
		foreach my $inc (@$class_incs_lr)
		{
			$inc =~ s/\"(.+)\"/\<$module_name\/interfaces\/$1\>/;
			push @includes, $inc;
		}
		$class_hr->{'__include'} = \@includes;
	}	
}

sub compile_typedef
{
	my ($data_hr, $current_class, $comments, $typedef) = @_;
	my $class_hr = $data_hr->{$current_class};
	if (!defined($class_hr->{"__typedefs"}))
	{
		$class_hr->{"__typedefs"} = [];
	}
	my $typedefs_lr = $class_hr->{"__typedefs"};
	push (@$typedefs_lr, $typedef);
}

sub compile_enum
{
	my ($data_hr, $parent, $class, $comments, @collector) = @_;
	my $class_hr = $data_hr->{$parent};
	if (!defined($class_hr->{"__enums"}))
	{
		$class_hr->{"__enums"} = {};
	}
	my $enums_hr = $class_hr->{"__enums"};
	
	my @data = @collector;
	$enums_hr->{$class} = {};
	$enums_hr->{$class}->{"__parent"} = $parent;
	$enums_hr->{$class}->{"__comments"} = $comments;
	$enums_hr->{$class}->{"__data"} = \@data;
	
	## Add to @not_classes and $type_map
	{
		my $prefix;
		my $macro_prefix;
		my $macro_suffix;
		my $macro_name;
		my $type_map_item_hr = {};
		my $enum_fullname = "$parent$class";
		
		# Add to @not_classes
		$not_classes->{$enum_fullname} = 1;
		
		# Add to $type_map
		get_canonical_names($enum_fullname, \$prefix, \$macro_prefix,
							\$macro_suffix, \$macro_name);
		## print "Enum Fullname: $enum_fullname\n";
		$type_map_item_hr->{'gtype'} = 'G_TYPE_ENUM';
		$type_map_item_hr->{'rettype'} = '0';
		$type_map_item_hr->{'type'} = $macro_prefix."_TYPE_".$macro_suffix;
		$type_map->{$enum_fullname} = $type_map_item_hr;
	}
}

sub compile_struct
{
	my ($data_hr, $parent, $class, $comments, @collector) = @_;
	my $class_hr = $data_hr->{$parent};
	if (!defined($class_hr->{"__structs"}))
	{
		$class_hr->{"__structs"} = {};
	}
	my $structs_hr = $class_hr->{"__structs"};
	
	my @data = @collector;
	$structs_hr->{$class} = {};
	$structs_hr->{$class}->{"__parent"} = $parent;
	$structs_hr->{$class}->{"__comments"} = $comments;
	$structs_hr->{$class}->{"__data"} = \@data;
	
	## Add to @not_classes and $type_map
	{
		my $prefix;
		my $macro_prefix;
		my $macro_suffix;
		my $macro_name;
		my $type_map_item_hr = {};
		my $struct_fullname = "$parent$class";
		
		# Add to @not_classes
		$not_classes->{$struct_fullname} = 1;
		
		# Add to $type_map
		## print "haha struct $struct_fullname\n";
		$type_map_item_hr->{'gtype'} = 'G_TYPE_POINTER';
		$type_map_item_hr->{'rettype'} = 'NULL';
		$type_map_item_hr->{'type'} = "G_TYPE_POINTER";
		$type_map->{"${struct_fullname}*"} = $type_map_item_hr;
	}
}

## GObject based C class files
sub generate_files
{
	my ($data_hr) = @_;
	foreach my $c (sort keys %$data_hr)
	{
		my $parent = $data_hr->{$c}->{'__parent'};
		print "Evaluating Interface $c";
		if ($parent ne '') {
			print ": $parent";
		}
		print "\n";
		generate_class($c, $data_hr->{$c});
	}
	write_marshallers();
	write_header();
	write_makefile();
}

sub get_canonical_names
{
	my ($class, $cano_name_ref, $cano_macro_prefix_ref,
		$cano_macro_suffix_ref, $cano_macro_ref) = @_;
	my $c = $class;
	
	while ($c =~ s/([A-Z])/\@$1\@/)
	{
		
		my $uw = $1;
		## print "Word separator: $uw\n";
		my $lw = lc($uw);
		$c =~ s/\@$uw\@/_$lw/;
	}
	$c =~ s/_(\w)_/_$1/g;
	$c =~ s/^_//;
	my $prefix = "";
	my $suffix = $c;
	if ($suffix =~ s/(\w+?)_//)
	{
		$prefix = $1;
	}
	
	$$cano_name_ref = $c;
	$$cano_macro_prefix_ref = uc($prefix);
	$$cano_macro_suffix_ref = uc($suffix);
	$$cano_macro_ref = uc($c);
}

sub get_arg_type_info
{
	my ($type, $info) = @_;
	if (defined ($type_map->{$type}))
	{
		if (defined ($type_map->{$type}->{$info}))
		{
			return $type_map->{$type}->{$info};
		}
	}
}

sub get_return_type_val
{
	my ($rettype) = @_;
	my $fail_ret = get_arg_type_info($rettype, "fail_return");
	if (!defined($fail_ret) || $fail_ret eq "")
	{
		## Return NULL for pointer types
		if ($rettype =~ /\*$/ ||
			$rettype =~ /gpointer/)
		{
			$fail_ret = "NULL";
		}
		else
		{
			$fail_ret = "0";
		}
	}
	return $fail_ret;
}

sub get_arg_assert
{
	my ($rettype, $type_arg, $force) = @_;
	my ($type, $arg);
	if ($type_arg =~ s/([\w_][\w\d_]*)+$//)
	{
		$arg = $1;
		$type = $type_arg;
		$type =~ s/\s//g;
	}
	if (!defined($force) || $force eq "")
	{
		$force = 0;
	}
	my $ainfo = get_arg_type_info($type, "assert");
	if (!defined($ainfo) || $ainfo eq "")
	{
		my $saved_type = $type;
		$type =~ s/\*//g;
		
		## Check if it is registred non-class type
		foreach my $nc (keys %$not_classes)
		{
			if ($type eq $nc)
			{
				return "";
			}
		}
		## Autodetect type assert
		if ($force ||
			(($saved_type =~ /\*$/) &&
			 ($type =~ /^Gtk/ ||
			  $type =~ /^Gdk/ ||
			  $type =~ /^Gnome/ || 
			  $type =~ /^Anjuta/ || 
			  $type =~ /^IAnjuta/)))
		{
			my $prefix;
			my $macro_prefix;
			my $macro_suffix;
			my $macro_name;
			get_canonical_names($type, \$prefix, \$macro_prefix,
								\$macro_suffix, \$macro_name);
			$ainfo = $macro_prefix."_IS_".$macro_suffix."(__arg__)";
		}
		else
		{
			## die "Cannot determine assert macro for type '$type'. Fix it first";
			return "";
		}
	}
	if ($rettype eq "void")
	{
		$ainfo =~ s/__arg__/$arg/;
		my $ret = "g_return_if_fail ($ainfo);";
		return $ret;
	}
	else
	{
		my $fail_ret = get_return_type_val ($rettype);
		if (defined($fail_ret))
		{
			$ainfo =~ s/__arg__/$arg/;
			my $ret = "g_return_val_if_fail ($ainfo, $fail_ret);";
			return $ret;
		}
	}
	die "Cannot determine failed return value for type '$rettype'. Fix it first";
}

sub construct_marshaller
{
	my ($rettype, $args) = @_;
	## Type mapping
	$rettype =~ s/\s//g;
	my $rtype = get_arg_type_info ($rettype, "gtype");
	if (!defined($rtype) or $rtype eq '')
	{
		die "Can not find GType for arg type '$rettype'. Fix it first.";
	}
	my $args_list = $rtype.",\n\t\t\t__arg_count__";
	$rtype =~ s/^G_TYPE_//;
	$rtype =~ s/NONE/VOID/;
	my $marshal_index = $rtype. "_";
	my $arg_count = 0;
	if ($args ne '')
	{
		my @params;
		my @margs = split(",", $args);
		foreach my $one_arg (@margs)
		{
			if ($one_arg =~ s/([\w_][\w\d_]*)$//)
			{
				$one_arg =~ s/\s//g;
				my $arg_gtype = get_arg_type_info ($one_arg, "gtype");
				my $arg_type = get_arg_type_info ($one_arg, "type");
				
				if (!defined($arg_gtype) or $arg_gtype eq '')
				{
					die "Can not find GType for arg type '$one_arg'. Fix it first.";
				}
				if (!defined($arg_type) or $arg_type eq '')
				{
					$arg_type = $arg_gtype;
				}
				$args_list .= ",\n\t\t\t$arg_type";
				$arg_gtype =~ s/^G_TYPE_//;
				$arg_gtype =~ s/NONE/VOID/;
				$marshal_index .= "_$arg_gtype";
				$arg_count++;
			}
		}
	}
	$args_list =~ s/__arg_count__/$arg_count/;
	if ($arg_count == 0)
	{
		$args_list .= ",\n\t\t\tNULL";
		$marshal_index .= "_VOID";
	}
	$marshallers{$marshal_index} = 1;
	$marshal_index = "${module_name}_iface_cclosure_marshal_$marshal_index";
	return $marshal_index.",\n\t\t\t".$args_list;
}

sub convert_ret
{
	my ($ret) = @_;
	
	if ($ret =~ /const List<.*>/)
	{
		return "const GList*";
	}
	elsif ($ret =~ /List<.*>/)
	{
		return "GList*";
	}
	else
	{
		return $ret;
	}
}

sub convert_args
{
	my ($args) = @_;
	my @argsv = split(',', $args);
	foreach my $arg (@argsv)
	{
		if ($arg =~ /const List<.*>.*/)
		{
			my @arg_name = split(' ', $arg);
			$arg = join(' ',"const GList*", $arg_name[-1]);
		}
		elsif ($arg =~ /.*List<.*>.*/)
		{
			my @arg_name = split(' ', $arg);
			$arg = join(' ', "GList*", $arg_name[-1]);
		}
	}
	$args = join(', ', @argsv);
	return $args;
}

sub enum_split
{
	(my $e) = @_;
	$e = substr($e, 0, 1) . "_" . substr($e, 1);
	return $e;
}

sub generate_class
{
	my ($class, $class_hr) = @_;
	my $parent = $class_hr->{'__parent'};
	
	my $prefix;
	my $macro_prefix;
	my $macro_suffix;
	my $macro_name;
	
	get_canonical_names($class, \$prefix, \$macro_prefix,
						\$macro_suffix, \$macro_name);
	
	my $macro_type = "${macro_prefix}_TYPE_${macro_suffix}";
	my $macro_assert = "${macro_prefix}_IS_${macro_suffix}";
	$macro_type =~ /^_/;
	$macro_assert =~ /^_/;
	
	my $parent_iface = "GTypeInterface";
	my $parent_type = "G_TYPE_OBJECT";
	my $parent_include = "";
	if ($parent ne "")
	{
		my ($pprefix, $pmacro_name, $pmacro_prefix, $pmacro_suffix);
		$parent_iface = "${parent}Iface";
		
		get_canonical_names($parent, \$pprefix, \$pmacro_prefix,
							\$pmacro_suffix, \$pmacro_name);
		$parent_type = $pmacro_prefix."_TYPE_".$pmacro_suffix;
		$pprefix =~ s/_/-/g;
		$parent_include = $pprefix.".h";
	}
	
	## print "\tmethod prefix: $prefix\n";
	## print "\tmacro prefix: $macro_prefix\n";
	## print "\tmacro suffix: $macro_suffix\n";
	## print "\tmacro name: $macro_name\n\n";

	my $filename = "$prefix.h";
	$filename =~ s/_/-/g;

	my $answer =
"/* -*- Mode: C; indent-tabs-mode: t; c-basic-offset: 4; tab-width: 4 -*- */
/*
 *  $filename -- Autogenerated from $idl_file
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU Library General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 */

#ifndef _${macro_name}_H_
#define _${macro_name}_H_

";
	my $class_incs_lr = $class_hr->{"__include"};
	foreach my $inc (@$class_incs_lr)
	{
		$answer .= "$inc\n";
	}
	if ($parent_include ne "")
	{
		$answer .= "#include <$module_name/interfaces/$parent_include>\n";
	}
	$answer .=
"
G_BEGIN_DECLS

#define $macro_type (${prefix}_get_type ())
#define ${macro_name}(obj) (G_TYPE_CHECK_INSTANCE_CAST ((obj), $macro_type, $class))
#define ${macro_assert}(obj) (G_TYPE_CHECK_INSTANCE_TYPE ((obj), $macro_type))
#define ${macro_name}_GET_IFACE(obj) (G_TYPE_INSTANCE_GET_INTERFACE ((obj), $macro_type, ${class}Iface))

";
	# Enum GType macros.
	my $enums_hr = $class_hr->{"__enums"};
	if (defined ($enums_hr))
	{
		foreach my $e (sort keys %$enums_hr)
		{
			# add an underscore if necassery
			my $se = $e;
			$se =~ s/[a-z][A-Z]/enum_split($&)/e;
			my $e_upper = uc($se);
			my $e_lower = lc($se);
			my $e_macro = "${macro_type}_${e_upper}";
			my $e_proto = "${prefix}_${e_lower}_get_type";
			$answer .=
"#define $e_macro ($e_proto())
";
		}
		$answer .= "\n";
	}
	
	## Added enums;
	if (defined ($enums_hr))
	{
		foreach my $e (sort keys %$enums_hr)
		{
			$answer .= "typedef enum {\n";
			foreach my $d (@{$enums_hr->{$e}->{"__data"}})
			{
				$answer .= "\t${macro_name}_$d\n";
			}
			$answer .= "} ${class}$e;\n\n";
		}
	}
	## Added structs;
	my $structs_hr = $class_hr->{"__structs"};
	if (defined ($structs_hr))
	{
		foreach my $s (sort keys %$structs_hr)
		{
			$answer .= "typedef struct _${class}$s ${class}$s;\n";
			$answer .= "struct _${class}$s {\n";
			foreach my $d (@{$structs_hr->{$s}->{"__data"}})
			{
				$d = normalize_namespace ($class, $d);
				$answer .= "\t$d\n";
			}
			$answer .= "};\n\n";
		}
	}
	
	$answer .=
"#define ${macro_name}_ERROR ${prefix}_error_quark()

";
	## Added Typedefs
	my $typedefs_lr = $class_hr->{"__typedefs"};
	if (defined ($typedefs_lr))
	{
		foreach my $td (@$typedefs_lr)
		{
			$td = normalize_namespace ($class, $td);
			$answer .= $td . "\n";
		}
		$answer .= "\n";
	}
	
	$answer .=
"typedef struct _$class $class;
typedef struct _${class}Iface ${class}Iface;

struct _${class}Iface {
	$parent_iface g_iface;
	
";
	foreach my $m (sort keys %$class_hr)
	{
		next if ($m =~ /^__/);
		my $func = $class_hr->{$m}->{'function'};
		my $rettype = normalize_namespace($class, $class_hr->{$m}->{'rettype'});
		my $args = normalize_namespace($class, $class_hr->{$m}->{'args'});
		$args = convert_args($args);
		if ($args ne '')
		{
			$args = ", ".$args;
		}
		if ($func =~ s/^\:\://)
		{
			$rettype = convert_ret($rettype);
			$answer .= "\t/* Signal */\n";
			$answer .= "\t$rettype (*$func) ($class *obj${args});\n";
		}
	}
	$answer .= "\n";
	foreach my $m (sort keys %$class_hr)
	{
		next if ($m =~ /^__/);
		my $func = $class_hr->{$m}->{'function'};
		my $rettype = normalize_namespace($class, $class_hr->{$m}->{'rettype'});
		my $args = normalize_namespace($class, $class_hr->{$m}->{'args'});
		$args = convert_args($args);
		if ($args ne '')
		{
			$args .= ", ";
		}
		if ($func !~ /^\:\:/)
		{
			$rettype = convert_ret($rettype);
			$answer .= "\t$rettype (*$func) ($class *obj, ${args}GError **err);\n";
		}
	}
	$answer .=
"
};
";
	# Enum GType prototypes.
	if (defined ($enums_hr))
	{
		foreach my $e (sort keys %$enums_hr)
		{
			# add an underscore if necassery
			my $se = $e;
			$se =~ s/[a-z][A-Z]/enum_split($&)/e;
			my $e_lower = lc($se);
			my $e_proto = "${prefix}_${e_lower}_get_type";
			$answer .=
"GType $e_proto (void);
";
		}
	}
	
	$answer .=
"
GQuark ${prefix}_error_quark     (void);
GType  ${prefix}_get_type        (void);

";
	foreach my $m (sort keys %$class_hr)
	{
		next if ($m =~ /^__/);
		my $func = $class_hr->{$m}->{'function'};
		my $rettype = normalize_namespace($class, $class_hr->{$m}->{'rettype'});
		my $args = normalize_namespace($class, $class_hr->{$m}->{'args'});
		$args = convert_args($args);
		if ($args ne '')
		{
			$args .= ", ";
		}
		if ($func !~ /^\:\:/)
		{
			$rettype = convert_ret($rettype);
			$answer .= "${rettype} ${prefix}_$func ($class *obj, ${args}GError **err);\n\n";
		}
	}
	$answer .=
"
G_END_DECLS

#endif
";
	write_file ($filename, $answer);
	push @header_files, $filename;
	
	## Source file.
	
	$answer = "";
	my $headerfile = $filename;
	$filename = "$prefix.c";
	$filename =~ s/_/-/g;
	my $dash_prefix = $prefix;
	$dash_prefix =~ s/_/-/g;
	$answer = 
"/* -*- Mode: C; indent-tabs-mode: t; c-basic-offset: 4; tab-width: 4 -*- */
/*
 *  $filename -- Autogenerated from $idl_file
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU Library General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 */

";
	# Added class (section) comments
	$answer .= $class_hr->{"__comments"};
	$answer .=
"
#include \"$headerfile\"
#include \"$module_name-iface-marshallers.h\"

GQuark 
${prefix}_error_quark (void)
{
	static GQuark quark = 0;
	
	if (quark == 0) {
		quark = g_quark_from_static_string (\"${dash_prefix}-quark\");
	}
	
	return quark;
}

";
	foreach my $m (sort keys %$class_hr)
	{
		next if ($m =~ /^__/);
		my $func = $class_hr->{$m}->{'function'};
		my $rettype = normalize_namespace($class, $class_hr->{$m}->{'rettype'});
		my $args = normalize_namespace($class, $class_hr->{$m}->{'args'});
		my $params = "";
		next if ($func =~ /^\:\:/);

		my $asserts = "\t".get_arg_assert($rettype, "$class *obj", 1)."\n";
		## self assert;
		$args = convert_args($args);
		if ($args ne '')
		{
			my @params;
			my @margs = split(",", $args);
			foreach my $one_arg (@margs)
			{
				my $assert_stmt = get_arg_assert($rettype, $one_arg, 0);
				if (defined($assert_stmt) && $assert_stmt ne "")
				{
					$asserts .= "\t$assert_stmt\n";
				}
				if ($one_arg =~ /([\w_][\w\d_]*)$/)
				{
					push @params, $1;
				}
			}
			$params = join (", ", @params);
			$params .= ", ";
		}
		
		$args = convert_args($args);
		if ($args ne '')
		{
			$args .= ", ";
		}
		my $comments_out = $class_hr->{$m}->{'__comments'};
		$rettype = convert_ret($rettype);
		$answer .= "${comments_out}${rettype}\n${prefix}_$func ($class *obj, ${args}GError **err)\n";
		$answer .= "{\n";
		if ($asserts ne "")
		{
			$answer .= $asserts;
		}
		$answer .= "\t";
		if ($rettype ne "void") {
			$answer .= "return ";
		}
		$answer .= "${macro_name}_GET_IFACE (obj)->$func (obj, ${params}err);";
		$answer .="\n}\n\n";

		## Default implementation
		$answer .= "/* Default implementation */\n";
		$answer .= "static ${rettype}\n${prefix}_${func}_default ($class *obj, ${args}GError **err)\n";
		$answer .= "{\n";
		if ($rettype ne "void") {
			$answer .= "\tg_return_val_if_reached (". get_return_type_val($rettype). ");";
		} else {
			$answer .= "\tg_return_if_reached ();";
		}
		$answer .="\n}\n\n";
	}
	$answer .=
"static void
${prefix}_base_init (${class}Iface* klass)
{
	static gboolean initialized = FALSE;

";
	foreach my $m (sort keys %$class_hr)
	{
		next if ($m =~ /^__/);
		my $func = $class_hr->{$m}->{'function'};
		next if ($func =~ /^\:\:/);
		$answer .= "\tklass->$func = ${prefix}_${func}_default;\n";
	}
	$answer .= "	
	if (!initialized) {
";
	foreach my $m (sort keys %$class_hr)
	{
		next if ($m =~ /^__/);
		my $func = $class_hr->{$m}->{'function'};
		my $rettype = normalize_namespace($class, $class_hr->{$m}->{'rettype'});
		my $args = normalize_namespace($class, $class_hr->{$m}->{'args'});
		$args = convert_args($args);
		if ($args ne '')
		{
			$args = ", ".$args;
		}
		if ($func =~ s/^\:\://)
		{
			my $signal = $func;
			$signal =~ s/_/-/g;
			
			my $marshaller = construct_marshaller($rettype, $args);
			$answer .= "\t\t/* Signal */";
			$answer .="\n\t\tg_signal_new (\"$signal\",
			$macro_type,
			G_SIGNAL_RUN_LAST,
			G_STRUCT_OFFSET (${class}Iface, $func),
			NULL, NULL,
			${marshaller});\n\n";
		}
	}
	
	$answer .=
"
		initialized = TRUE;
	}
}

GType
${prefix}_get_type (void)
{
	static GType type = 0;
	if (!type) {
		static const GTypeInfo info = {
			sizeof (${class}Iface),
			(GBaseInitFunc) ${prefix}_base_init,
			NULL, 
			NULL,
			NULL,
			NULL,
			0,
			0,
			NULL
		};
		type = g_type_register_static (G_TYPE_INTERFACE, \"$class\", &info, 0);
		g_type_interface_add_prerequisite (type, $parent_type);
	}
	return type;			
}
";
	# Enum GTypes.
	if (defined ($enums_hr))
	{
		foreach my $e (sort keys %$enums_hr)
		{
			# add an underscore if necassery
			my $se = $e;
			$se =~ s/[a-z][A-Z]/enum_split($&)/e;
			my $e_lower = lc($se);
			$answer .=
"
GType
${prefix}_${e_lower}_get_type (void)
{
	static const GEnumValue values[] =
	{
";
			foreach my $d (@{$enums_hr->{$e}->{"__data"}})
			{
				$d =~ s/^([\w_\d]+).*$/$1/;
				my $e_val = "${macro_name}_$d";
				my $e_val_str = lc($d);
				$e_val_str =~ s/_/-/g;
				$answer .= "\t\t{ $e_val, \"$e_val\", \"$e_val_str\" }, \n";
			}
			$answer .=
"		{ 0, NULL, NULL }
	};

	static GType type = 0;

	if (! type)
	{
		type = g_enum_register_static (\"${class}$e\", values);
	}

	return type;
}
";
		}
	}
	write_file ($filename, $answer);
	push @source_files, $filename;
}

sub write_marshallers
{
	## Write marshallers
	my $filename = "$module_name-iface-marshallers.list";
	push @header_files, "$module_name-iface-marshallers.h";
	push @source_files, "$module_name-iface-marshallers.c";
	my $contents = "";
	foreach my $m (sort keys %marshallers)
	{
		$m =~ s/__/\:/;
		$m =~ s/_/\,/g;
		$contents .= "$m\n";
	}
	if (write_file ($filename, $contents))
	{
		system "echo \"#include \\\"${module_name}-iface-marshallers.h\\\"\" ".
		"> xgen-gmc && glib-genmarshal --prefix=${module_name}_iface_cclosure_marshal ".
		"./${module_name}-iface-marshallers.list --body >> xgen-gmc && cp xgen-gmc ".
		"$module_name-iface-marshallers.c && rm -f xgen-gmc";
		system "glib-genmarshal --prefix=${module_name}_iface_cclosure_marshal ".
		"./${module_name}-iface-marshallers.list --header > xgen-gmc && cp xgen-gmc ".
		"$module_name-iface-marshallers.h && rm -f xgen-gmc";
	}
}

sub write_header
{
	my $iface_headers = "";
	my $answer = 
"
/* Interfaces global include file */

";
;
    foreach my $h (@header_files)
    {
    	$answer .= "#include \"$h\"\n";
	}
    write_file("libanjuta-interfaces.h", $answer);
    push(@header_files, "libanjuta-interfaces.h");
}

sub write_makefile
{
    my $iface_headers = "";
    foreach my $h (@header_files)
    {
	$iface_headers .= "\\\n\t$h";
    }
    my $iface_sources = "";
    foreach my $s (@source_files)
    {
	$iface_sources .= "\\\n\t$s";
    }
    
    my $iface_rules = "noinst_LTLIBRARIES = $module_name-interfaces.la\n";
    $iface_rules .= "${module_name}_interfaces_la_LIBADD = \$(MODULE_LIBS)\n";
##    $iface_rules .= "${module_name}_interfaces_la_LIBADD = \n";
    $iface_rules .= "${module_name}_interfaces_la_SOURCES = $iface_sources\n";
    $iface_rules .= "${module_name}_interfaces_includedir = \$(MODULE_INCLUDEDIR)\n";
    $iface_rules .= "${module_name}_interfaces_include = $iface_headers\n";
    
    my $contents = `cat Makefile.am.iface`;
    $contents =~ s/\@\@IFACE_RULES\@\@/$iface_rules/;
    my $filename = "Makefile.am";
	write_file ($filename, $contents);
}

sub write_file
{
	my ($filename, $contents) = @_;
    open (OUTFILE, ">$filename.tmp")
		or die "Can not open $filename.tmp for writing";
    print OUTFILE $contents;
    close OUTFILE;
	
	my $diff = "not matched";
	if (-e $filename)
	{
		$diff = `diff $filename $filename.tmp`;
	}
	unlink ("$filename.tmp");
	if ($diff !~ /^\s*$/)
	{
		print "\tWriting $filename\n";
		open (OUTFILE, ">$filename")
			or die "Can not open $filename for writing";
		print OUTFILE $contents;
		close OUTFILE;
		return 1;
	}
	return 0;
}