#!/usr/bin/env perl

$serializer_method = "Serialize";
$deserializer_method = "Deserialize";

# Parse command line arguments
$debug_level = 0;
my $binary_file = "";
foreach (@ARGV){
	if(/^-h/){
		&Usage();
	}elsif(/-d/){
		$debug_level++;
	}elsif(/c=/){
		push(@clclasses, $');
		$user_supplied_classes = "true";
	}elsif(/classes=/){
		open(FILE, $');
		foreach(<FILE>){chomp; if(length($_)>0){push(@clclasses, $_);}}
		close(FILE);
		$user_supplied_classes = "true";
	}elsif(/methods=/){
		if($' eq "yes"){$print_methods = true;}
	}else{
		$binary_file = $_;
	}
}
if(length($binary_file) == 0){&Usage();}


# Get the names of all class/struct types from the specified binary
my $typenamesref;
if($user_supplied_classes eq "true"){
	$typenamesref = \@clclasses;
}else{
	$typenamesref = &GetClasses($binary_file);
}

# Get the class definitions for the classes listed in $typenamesref
my $classrefs = &GetClassDefinitions($typenamesref);

# Filter out classes that don't have the serializer method
# And don't appear anywhere in the type tree of a class that
# does have a serializer method.
$filteredrefs = &FilterClassDefinitions($classrefs);

# Sort filtered classes in alphabetical order by classname
@$filteredrefs = sort {$$a{"classname"} cmp $$b{"classname"}}(@$filteredrefs);

# Determine output filename based on input filename
@paths = split(/\//, $binary_file);
$xmlfilename = pop(@paths).".xml";
open(FILE, ">$xmlfilename");
print "Writing $xmlfilename ... ";

# Print out all of the classes in the filtered list
my $classref;
print FILE "<JILDictionary>\n";
$tabs .= "\t";
foreach $classref (@$filteredrefs){
	&PrintClass($classref);
}
chop($tabs);
print FILE "</JILDictionary>\n";
close(FILE);
open(FILE,"$xmlfilename");
@lines = <FILE>;
close(FILE);
print @lines." lines\n";

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

sub Usage()
{
	print "\n";
	print "Usage:\n";
	print "       jil_exe2xml [options] executable_file\n";
	print "\n";
	print " This script is part of the JIL (JLab Introspection Library) package.\n";
	print "jil_exe2xml takes an executable binary file created by the GNU compiler/\n";
	print "linker. The executable must have debugging symbols included (see the -g\n";
	print "option \n";
	
	print "\n";
	exit(0);
}

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

sub GetClasses()
{
	my $binary_file = $_[0];

	my $gdb_commands_file = "tmp2.gdb";
	open(GDB, ">$gdb_commands_file");
	print GDB "info types\n";
	close(GDB);

	# Run gdb using the command file we just created and capture
	# the output
	my $gdb_output = `gdb $binary_file -batch -x $gdb_commands_file`;

	# Clean up temporary file
	if($debug_level==0){unlink $gdb_commands_file;}

	my @typenames;
	my @lines = split(/\n/, $gdb_output);
	my %used;
	foreach $line (@lines){
		# Chop off trailing semi-colon
		chop($line);

		# We only want the typedef lines, but not those with std::allocator
		if($line !~ /^typedef/){next;}
		if($line =~ /std::allocator/){next;}
		
		# Typename is entire line after the "typedef "
		$line =~ /^typedef /;
		$typename = $';
	
	
		# Filter out atomic types
		if($typename eq "char"){next;}
		if($typename eq "int"){next;}
		if($typename eq "float"){next;}
		if($typename eq "void"){next;}
		if($typename eq "bool"){next;}
		if($typename eq "double"){next;}
		if($typename eq "struct"){next;}
	
		# Types that are auto-generated or in standard libraries or
		# just plain cause problems when passed to gdb's ptype command
		if(length($typename) == 0){next;}
		if($typename =~ /^allocator\</){next;}
		if($typename =~ /^ios_base/){next;}
		if($typename =~ /^iterator\</){next;}
		if($typename =~ /^std::/){next;}
		if($typename =~ /^locale::/){next;}
		if($typename =~ /^__/){next;}
		if($typename =~ /^int /){next;}
		if($typename =~ /^long /){next;}
		if($typename =~ /^short /){next;}
		if($typename =~ /^signed /){next;}
		if($typename =~ /^unsigned /){next;}
		if($typename =~ /^struct /){next;}
		if($typename =~ /^new_allocator\</){next;}
		if($typename =~ /^_Ios_/){next;}
		if($typename =~ /^_List_/){next;}
		if($typename =~ /^_Vector_/){next;}
		if($typename =~ /_Is_normal_iterator\</){next;}
		if($typename =~ /\$\_/){next;}
		if($typename =~ /\&/){next;}
		if($typename =~ /\./){next;}
		if($typename =~ /thread_mutex_t/){next;}
		if($typename =~ /\s\*/){next;}
		
		# enums defined within a class can appear as:
		# myenum_t myClass::myenum_t
		# They also appear without the second string.
		# filter these out.
		my @tokens = split(/\s+/, $typename);
		my $t0 = $tokens[0];
		my $t1 = $tokens[1];
		if($t1 =~ /::$t0/){next;}
	
		if($used{$typename} ne "yes"){
			push(@typenames, $typename);
			$used{$typename} = "yes";
		}
	}
	
	\@typenames; # Return list of class names
}


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

sub GetClassDefinitions()
{
	my @classes = @{$_[0]};
	@class_definitions = ();

	# Create a temporary file to hold the commands for gdb
	$gdb_commands_file = "tmp.gdb";
	open(GDB, ">$gdb_commands_file");
	foreach $class (@classes){print GDB "ptype $class\n";}
	close(GDB);

	# Run gdb using the command file we just created and capture
	# the output
	$gdb_output = `gdb $binary_file -batch -x $gdb_commands_file`;

	# Clean up temporary file
	if($debug_level==0){unlink $gdb_commands_file;}

	# Split the output into the individual class definitions
	@classdefs = split(/type = (class|struct|enum) /, $gdb_output);
	my $classindex = -1;
	my $class_struct_enum = "";
	foreach $classdef (@classdefs){
		if($classdef eq "enum" || $classdef eq "class" || $classdef eq "struct"){
			# The @classdefs split above keeps the class,struct, or enum
			# string as an item in the @classdefs array because of the 
			# parentheses(). Since it appears as the entry before the actual
			# type definition, we copy it here for use on the next item.
			# We need this info so we can set the isenum flag.
			$class_struct_enum = $classdef;
		}

		@lines = split(/\n/, $classdef);
		if ($lines[0] !~ /\{/){next;} # Filter out non type-def lines
		$classindex++;

		# Initialize arrays that will hold class definitions
		%classdef = ();
		@datas = ();
		@methods = ();
		$hasSerializer = "";
		$hasDeserializer = "";
		if($class_struct_enum eq "enum"){$classdef{"isEnum"} = "true";}

		# Loop over lines of the definition
		$i = 0;
		$section = "public";
		foreach $line (@lines){
			
			# On some versions of gdb, template classes based on multiple
			# types have a space after the commas that seperate the types.
			# Remove those spaces here so that the whole templated type
			# is put into one token
			$line =~ s/\, /\,/g;
			
			# Get rid of std:: qualifiers. They are superfluous to us
			$line =~ s/std:://g;
		
			@tokens = split(/\s+/, $line);
			
			# If the first "token" is empty, remove it
			if(length($tokens[0])<1){
				@tokens = reverse(@tokens);
				pop(@tokens);
				@tokens = reverse(@tokens);
			}
			
			if($i++ == 0){
				# Get class and base class from first line
				# Format will be:
				# class : public base_class {\n
				$classname = $tokens[0];
				$baseclass = $tokens[3];
				
				# Some gdb versions will only print "typedef struct {",
				# omitting the actual type name. We try and recover by
				# using the name from the @classes array.
				if($classname =~ /^\{/){
					$classname = $classes[$classindex];
				}
				
				# For templated types, the name contains angle brackets <>
				# These are special in XML so we need to replace them
				$classname =~ s/\</\{/g ;
				$classname =~ s/\>/\}/g ;
				$baseclass =~ s/\</\{/g ;
				$baseclass =~ s/\>/\}/g ;
				
				$classdef{"classname"} = $classname;
				$classdef{"baseclass"} = $baseclass;
				
			}elsif($line =~ /public:/) {
				# Switch to public definition section
				$section = "public";
			}elsif($line =~ /protected:/) {
				# Switch to protected definition section
				$section = "protected";
			}elsif($line =~ /private:/) {
				# Switch to private definition section
				$section = "private";
			}else{
				# Must be a data member or method.

				# Remember if this class has a (de)serializer method.
				if($line =~ /$serializer_method\(/){$classdef{"hasSerializer"} = "true";}
				if($line =~ /$deserializer_method\(/){$classdef{"hasDeserializer"} = "true";}
				
				# If there is a round bracket, then it must be a method
				if($line =~ /\(/){
					# chop off leading white space and replace angle brackets
					# with curly ones
					my $method = $line;
					$method =~ s/^\s+//g;
					$method =~ s/\>/\}/g;
					$method =~ s/\</\{/g;
					$method =~ s/\&/\%/g;
					$methoddef{"method"} = $method;
					$methoddef{"section"} = $section;
					%$methodref = %methoddef;
					push(@methods, $methodref);
					undef $methodref;
					next;
				}
				
				# Skip closing bracket for class definition
				if($line =~ /\{/){next;}
				
				# Skip other type definitions
				if($line =~ /^type =/){next;}
				
				# Extract variable name
				$varname = pop(@tokens); # last token is variable name
				chomp($varname);	# Remove trailing \n
				chop($varname);	# Remove semi-colon

				# if varname is empty, we must be at the boundary between
				# the data and method sections.
				if(length($varname) == 0){next;}
				
				# If the variable is a fixed-length array, move the array
				# definition (the [] and size) onto the type definition
				if($varname =~ /\[/){
					$size_spec = "[".$';
					$varname = $`;
					$tmp = pop(@tokens);
					push(@tokens, $tmp.$size_spec);
				}
				
				#if($varname =~ /\]$/){
				#	# We need the array size. Get it by splitting on "["
				#	# and taking the last element.
				#	@tmp = split(/\[/, $`);
				#	$size = pop(@tmp);
				#	$tmp = pop(@tokens);
				#	push(@tokens, $tmp."[$size]");
				#	$varname =~ s/\[$size\]//;  # remove [size] from variable name
				#}

				# If the variable is a pointer then the varname is
				# pefixed by a "*". Push it on to the type definition
				# so it gets written in the right place
				if($varname =~ /^\*/){
					$varname = $';
					$tmp = pop(@tokens)."*";
					push(@tokens, $tmp);
				}
				
				# Remaining tokens are the type definition
				$type = "@tokens";				

				$datadef{"name"} = $varname;
				$datadef{"section"} = $section;
				$tmpref = &ParseTypeDefinition($type);
				%$tmpref2 = %$tmpref;
				$datadef{"typedef_ref"} = $tmpref2;
				undef $tmpref;
				undef $tmpref2;
				
				%$tmpref = %datadef;
				push(@datas, $tmpref);
				undef $tmpref;
				
			} #if
		} #line
		
		# Record the member data with the class definition and push it
		# onto the list of class definitions. Note that the %$tmpref
		# business is creating an "Anonymous Data" copy of the %classdef
		# hash. In other words, it makes a copy without a variable, only
		# a reference. Analogous to C++ "new"
		@$tmpref = @datas;
		$classdef{"data_arrayref"} = $tmpref;
		undef $tmpref;
		@$tmpref = @methods;
		$classdef{"methods_arrayref"} = $tmpref;
		undef $tmpref;
		%$tmpref = %classdef;
		push(@class_definitions, $tmpref);
		undef $tmpref;
	} #classdef
	
	\@class_definitions;
}


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

sub ParseTypeDefinition()
{
	# This routine can get called recursively (i.e. it can call itself)
	# Thus, we need to make a local copy of the @tokens array
	
	my($typedef, %typedef);  # %typedef is hash object to hold type definition
	$typedef = $_[0];
	#print "$typedef\n";

	# Check if this type is a pointer or not
	if($typedef =~ /\*$/){
		$typedef{"pointer"} = true;
		chop($typedef);  # remove trailing "*"
	}
	
	# For pointers to STL types, the type is prefixed by "struct "
	# For us, this is superfluous. Remove it.
	if($typedef =~ /^struct /){$typedef = $';}
	
	# Split typedef into tokens
	my(@tokens);
	@tokens = split(/\s+/, $typedef);

	# STL vector, list, map, and string classes are treated
	# special.The symbol names contains stuff about std:allocator...
	# that we don't need to remember.
	my($templatebase, $isconst, $isstatic, $size);
	if($typedef =~ /^vector</){
		$' =~ /,/;
		$templatebase = $`;
		$type = "vector";
	}elsif($typedef =~ /^list</){
		$' =~ /,/;
		$templatebase = $`;
		$type = "list";
	}elsif($typedef =~ /^class basic_string</){
		$type = "string";
	}elsif($typedef =~ /\]$/){
		# $size_list is comma separated list of array dimensions
		# $size_spec is array diminsion in bracketed form a'la C
		$` =~ /\[/;
		$type = $`;
		$size_spec = "[".$'."]";
		$size_list = $';
		$size_list =~ s/\]\[/\,/g;
		$typedef{"size"} = $size_list;
				
				
		#@tmp = split(/\[/, $`);
		#$size = pop(@tmp);
		#$type = $typedef;
		#$type =~ s/\[$size\]//;  # remove [size] from variable name
		#$typedef{"size"} = $size;
	}else{
		foreach $attribute (@tokens){
			if($attribute =~ /const/){$typedef{"const"}=true;}
			elsif($attribute =~ /static/){$typedef{"static"}=true;}
			elsif($attribute =~ /unsigned/){$typedef{"unsigned"}=true;}
			elsif($attribute =~ /long/ && $type eq "int"){$type="long";}
			else{
				$type = $attribute;
			}
		}
	}
	
	# For templated types, $type contains angle brackets <>
	# These are special in XML so we need to replace them
	$type =~ s/\</\{/g ;
	$type =~ s/\>/\}/g ;
	$typedef{"type"} = $type;

	# For STL classes, we need to record the definition of the
	# type on which we're based.
	if(length($templatebase)>0){
		# For STL types based on other STL types, the typedef is
		# cut off at the first comma. Add a comma back on in those
		# cases so the above code will properly find the type.
		if($templatebase =~ /^(vector\<|list\<)/){$templatebase .= ",";}

		$typedef{"typebaseref"} = &ParseTypeDefinition($templatebase);
	}
	
	\%typedef; # return reference to the type definition
}

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

sub FilterClassDefinitions
{
	# Here we want to find the sublist of the class definitions passed
	# to us that contains 1. all of the classes that have serializer
	# methods and 2. all of the classes that the ones from 1. depend on.
	# Note that gcc turns all structures into classes. These will
	# necessarily NOT have serializer methods. We would still like to
	# to write those "struct" definitions out though so that the objects that
	# use them can try embedding the struct serialization inside the
	# class serializer.
	#
	# Since the class definitions can have nested types that are
	# arbitrarily deep (vectors of lists of ...) we need to recursively
	# loop through the types, building a list of the dependent classes as
	# we go.

	my $classrefs = $_[0];
	
	# First, just make a list of the classes with a serializer method
	foreach $classref (@$classrefs){
		my $classname = $$classref{"classname"};

		# Add class if it has a serializer method declared or ...
		if($$classref{"hasSerializer"} eq "true"){
			&AddClassToOutput($classname, $classrefs);
		}

		# ... the user supplied the classes
		if($user_supplied_classes eq "true"){
			&AddClassToOutput($classname, $classrefs);
		}
	}
	
	# Copy class definition references into a scaler array
	while(($classname, $classref) = each %filtered){
		push(@filtered, $classref);
	}
	
	\@filtered;
}

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

sub AddClassToOutput()
{
	my $classname = $_[0];
	my $classrefs = $_[1];
	
	# Avoid infinite recursion
	#print "$tabs Adding class -- $classname\n";	
	if(length($filtered{$classname})>0){return;}
	
	my $classref = &FindClassRef($classname, $classrefs);
	if(length($classref)<=0){return;}
	$filtered{$classname} = $classref;	
	
	# Add base class (if any)
	$tabs .= "\t";
	if(length($$classref{"baseclass"})>0){
		#print "$tabs Adding base class -- ".$$classref{"baseclass"}."  classname=".$$classref{"classname"}."\n";
		&AddClassToOutput($$classref{"baseclass"}, $classrefs);
	}
	
	# Add classes/structs from member data
	my $datarefs = $$classref{"data_arrayref"};
	my $dataref;
	#print "$tabs Added class --- ".$$classref{"classname"}." ref=$classref\n";	
	foreach $dataref (@$datarefs){
		my $typeref = $$dataref{"typedef_ref"};
		#print "$tabs type=".$$typeref{"type"}."\n";
		&AddTypeToOutput($typeref, $classrefs);
	}
	chop($tabs);
}


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

sub AddTypeToOutput()
{
	my $typeref = $_[0];
	my $classrefs = $_[1];
	
	# This may be a class name or an atomic type (int, float etc.)
	my $typename = $$typeref{"type"};
	
	#print "$tabs Adding type -- $typename  ref = $typeref\n";
	
	# Avoid infinite recursion
	if(length($filtered{$typename})>0){return;}

	# Try adding this type. If it's not a class, it will be ignored
	# by AddClassToOutput()
	$tabs .= "\t";
	&AddClassToOutput($typename, $classrefs);

	# If this type is based on another type (e.g. it's an STL vector)
	# then add the type it's based on to the filtered list as well
	my $basetyperef = $$typeref{"typebaseref"};
	if(length($basetyperef)>0){&AddTypeToOutput($basetyperef, $classrefs);}
	chop($tabs);
}


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

sub FindClassRef()
{
	my $classname = $_[0];
	my $classrefs = $_[1];
	my $classref;

	foreach $classref (@$classrefs){
		#print "Comparing $classname to ".$$classref{"classname"}."  ref=".$classref."\n";
		if($classname eq $$classref{"classname"}){
			return $classref;
		}
	}
	
	return "";
}

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

sub PrintClass()
{
	my $classref = $_[0];
	my $datarefs = $$classref{"data_arrayref"};

	# Enums are trivial for out purposes
	if($$classref{"isEnum"} eq "true"){
		print FILE "$tabs<enum name=\"".$$classref{"classname"}."\"/>\n";
		return;
	}

	# Open Class tag
	my $classname = $$classref{"classname"};
	print FILE "$tabs<class name=\"$classname\"";
	if(length($$classref{"baseclass"})>0){
		print FILE " baseclass=\"".$$classref{"baseclass"}."\"";
	}
	if($$classref{"hasSerializer"} eq "true"){print FILE " hasSerializer=\"true\"";}
	if($$classref{"hasDeserializer"} eq "true"){print FILE " hasDeserializer=\"true\"";}
	print FILE ">\n";
	
	# Add data member tags
	$tabs .= "\t";
	foreach $dataref (@$datarefs){

		# Write type definition
		&PrintType($$dataref{"typedef_ref"}, $$dataref{"name"}, $$dataref{"section"});
	}

	# Add methods
	if($print_methods eq true){
		my $methodrefs = $$classref{"methods_arrayref"};
		my $methodref;
		foreach $methodref (@$methodrefs){
			print FILE "$tabs<method";
			print FILE " section=\"".$$methodref{"section"}."\"";
			print FILE " method=\"".$$methodref{"method"}."\"";
			print FILE "/>\n";
		}
	}
	chop($tabs);

	# Close Class tag
	print FILE "$tabs</class>\n\n";
}

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

sub PrintType()
{
	my $typeref = $_[0];
	my $varname = $_[1];
	my $section = $_[2];

	# Open type tag
	my $type = $$typeref{"type"};
	print FILE "$tabs<typedef type=\"$type\"";
	if(length($varname)>0){print FILE " name=\"$varname\" section=\"$section\"";}
	
	@attributes = ("const", "static", "unsigned", "pointer");
	foreach $att (@attributes){
		if($$typeref{$att} eq "true"){print FILE " $att=\"true\"";}
	}
	$size = $$typeref{"size"};
	if(length($size)>0){print FILE " size=\"$size\"";}
	
	if(length($$typeref{"typebaseref"})>0){
		# Type is based on another. Put based-on-type on its own line(s)
		print FILE ">\n";
		$tabs .= "\t";
		&PrintType($$typeref{"typebaseref"});
		chop($tabs);
		print FILE "$tabs</typedef>\n";
	}else{
		# Simple type. Close tag on same line
		print FILE "/>\n";
	}
}