path: root/lib/Automake/Parser/Tree.pm

package Tree;

use Exporter;

our @ISA = qw(Exporter);
our @EXPORT = qw(basedir input stmts stmt automakerule makerule conditional ifblock 
optionalelse optionalcond optionalrhs optionalcomments includerule lhs rhs commentlist primaries 
optionlist traverse printgraph recursesubdirs);

# Stores whether subdir directive is used or not. If used array
# consist of subdirectories.
my $isSubdir = 0 , @subdirnodes = ();

# Stores the value recieved by Parser.pl
our $basedir;

# Grammar Rule : (1) input => stmts
# Create a node having child as stmts.
sub input($)
{
	my ( $val ) = @_;
	my %node = ( name => input, childs => [ $val ] );
	push @{ $node{ childs } }, subdirNode() if $#subdirnodes > -1;
	return \%node;
}

# Creates a Node having all the sub directories which are to be recursed.
sub subdirNode()
{
	my %node = ( name => subdir, empty => 1 );
	my @subdir = ();
	push @subdir, @{ $_ -> { value }} foreach @subdirnodes;
	$node{ subdirs } = \@subdir;
	return \%node;
}

# Grammar Rule : (1) stmts=> stmt '\n'
# Creates a node having a child as stmt
#				 (2) stmts=> stmts stmt '\n'
# Creates a node having a child as stmt. Insert the created node into 
# the childs array of the stmts(First Argument).
sub stmts($$;$)
{
	my ( $val1, $val2, $val3) = @_;
	if($val3 == undef)
	{
		my %node = ( name => stmts, childs => [ $val1 ]);
		return \%node;
	}
	else
	{
		push @{ $val1 -> { childs } }, $val2;
		return $val1;
	}
}


# Grammar Rule : (1) stmt => automakerule
#				 (2) stmt => makerule
#				 (3) stmt => commentlist
#				 (4) stmt => conditional
#				 (5) stmt => includerule
# Create a node with corresponding child node.
sub stmt($)
{
	my ( $val1 ) = @_;
	my %node = ( name => stmt , childs => [ $val1 ]);
	return \%node;
}

# Grammar Rule : (1) automakerule => lhs '=' optionalrhs optionalcomments
# 				 (2) automakerule => lhs '+' '=' optionalrhs optionalcomments
# Create a node for automake rule.
sub automakerule($$$$;$)
{
	my ( $val1, $val2, $val3, $val4, $val5 ) = @_;
	my %node = (name => automakerule, childs => [ $val1 ]);
	if($val2 -> [0] eq '=')
	{
		push @{ $node{ childs }}, $val3;
		push @{ $node{ childs }}, $val4 if $val4;
	}
	else
	{
		push @{ $node{ childs }}, $val4;
		push @{ $node{ childs }}, $val5 if $val5;
		$node{ append } = true;
	}
	return \%node;
}

# Grammar Rule : (1) makerule => value ':' rhs
# Create a node for make rule.
sub makerule($$$)
{
	my ( $val1, $val2, $val3 ) = @_;
	my %node = ( name => makerule, childs => [ $val1,$val3 ]);
	return \%node;
}

# Grammar Rule : (1) optionalrhs =>
# Create an empty node.
#				 (2) optionalrhs => rhs
# Create a node with rhs as child.
sub optionalrhs(;$)
{
	my ( $val ) = @_;
	my %node = ( name => optionalrhs );
	if( $val == undef )
	{
		$node{ empty } = 1;
	}
	else
	{
		$node{ childs } = [ $val ];
		push @subdirnodes, $val if $isSubdir;
	}
	$isSubdir = 0;
	return \%node;
}

# Grammar Rule : (1) optionalcomments => 
# Create an empty node.
# 				 (2) optionalcomments => commentlist
# Create a node with commentlist as child.
sub optionalcomments(;$)
{
	my ( $val ) = @_;
	my %node = ( name => optionalcomments );
	if( $val == undef )
	{
		$node{ empty } = 1;
	}
	else
	{
		$node{ childs } = [ $val ];
	}
	return \%node;
}

# Grammar Rule : (1) conditional => ifblock optionalelse endif optionalcond
# Create a node for conditional statement.
sub conditional($$$)
{
	my ( $val1, $val2, $val3 ) = @_;
	my %node = ( name => conditional, childs => [ $val1, $val2]);
	return \%node;
}

# Grammar Rule : (1) ifblock => if value newline stmts
# Create a node for if block.
sub ifblock($$$$$)
{
	my ( $val1, $val2, $val3, $val4, $val5) = @_;
	my %node = ( name => ifblock, condition => $val2 -> [1], childs => [$val4]);
	return \%node;
}

# Grammar Rule : (1) optionalelse =>
# Create an empty node.
#				 (2) optionalelse => else newline stmts
# Create a node with child as automakerule.
sub optionalelse(;$$$$)
{
	my ( $val1, $val2, $val3, $val4 ) = @_;
	my %node = ( name => optionalelse );
	if( $val1 == undef )
	{
		$node{ empty } = 1;
	}
	else
	{
		$node{ childs } = [ $val3 ];
	}
	return \%node;
}

# Grammar Rule : (1) optionalcond =>
# Create an empty node.
#				 (2) optionalcond => value
# Create a node with child as automakerule.
sub optionalcond(;$)
{
	my ( $val1 ) = @_;
	my %node = ( name => optionalcond );
	if( $val1 == undef )
	{
		$node{ empty } = 1;
	}
	else
	{
		$node{ value } = $val1->[1];
	}
	return \%node;
}

# Grammar Rule : (1) lhs => optionlist primaries
# Create a node for left hand side of variable defination consisting of 
# option list and primary.
#                (2) lhs => value
# Create a node for left hand side of variable defination having a simple
# variable defination.
sub lhs($;$)
{
	my ( $val1, $val2 ) = @_;
	my %node = ( name => lhs);
	if( $val2 == undef )
	{
		$node{ value } = $val1 -> [1];
		$isSubdir = 1 if $node{value} eq 'SUBDIRS';
	}
	else
	{
		$node{ childs } = [ $val1, $val2 ];
	}
	return \%node;
}

# Grammar Rule : (1) rhs => rhsval
# Creates a node having rhsval as its value.
#				(2) rhs => rhs rhsval
# Inserts rhsval into the array pointed by value key in rhs.		
sub rhs($;$)
{
	my ( $val1, $val2 ) = @_;
	if($val2 == undef)
	{
		my %node = ( name => rhs, value => [$val1 -> [1]]);
		return \%node;
	}
	else
	{
		push @{ $val1 -> { value }}, $val2 -> [1];
		return $val1;
	}
}

# Grammar Rule : (1) commentlist => comment
# Creates a node having comment as its value.
#				(2) commentlist => commentlist comment
# Inserts comment into the array pointed by value key in commentlist.
sub commentlist($;$)
{
	my ( $val1, $val2 ) = @_;
	if( $val2 == undef )
	{
		my %node = ( name => commentlist, value => [ $val1 -> [1]]);
		return \%node;
	}
	else
	{
		push @{ $val1 -> { value }} , $val2 -> [1];
		return $val1;
	}
}

# Grammar Rule : (1) primaries : PROGRAMS
#				 (2) primaries : LIBRARIES
#				 (3) primaries : LTLIBRARIES
#				 (4) primaries : LISP
#				 (5) primaries : PYTHON
#				 (6) primaries : JAVA
#				 (7) primaries : SCRIPTS
#				 (8) primaries : DATA
#				 (9) primaries : HEADERS
#				 (10) primaries : MASN
#				 (11) primaries : TEXINFOS
#				 (12) primaries : value
# Creates a node corresponding to the given primary.
sub primaries($)
{
	my ( $val ) = @_;
	my %node = ( name => primaries );
	if( $val -> [0] eq 'value')
	{
		$node{ value } = $val -> [1];
	}
	else
	{
		$node{ value } = $val;
	}
	return \%node;
}

# Grammar Rule : (1) optionlist : value '_'
# Create a node having data value in val key.
#				 (2) optionlist : optionlist value '_'
# Add the data value to val key in the node pointed by optionlist(First Argument).
sub optionlist($$;$)
{
	my ( $val1, $val2, $val3 ) = @_;
	if($val3 == undef)
	{
		my %node = (name => optionlist, val => [$val1 -> [1]]);
		return \%node;
	}
	else
	{
		push @{$val1 -> {val}},$val2 -> [1];
		return $val1;
	}
}

# Grammar Rule : (1) includerule : include value
# Create a node having the tree after parsing the included value.
# String recieved as standard input is evaled to generate corresponding
# tree.
sub includerule($$)
{
	my ( $val1, $val2 ) = @_;
	my $VAL1;
	my $file = $val2 -> [1];
	my $data = `parser.pl -include $basedir/$file`;
	my %node = %{ eval( $data ) };
	$node{ name } = includerule;
	$node{ file } = $val2;
	return \%node;
}

# printgraph(Hash)
# prints the AST to Standard Output by traversing the tree starting at node
# pointed by hash.
sub printgraph($)
{
	print "graph graphname {\n";
	my ( $ref ) = @_;
	print "0 [label=\"Root\"];";
	traverse( $ref, 0 );
	print "}\n";
}

#Stores the next id to be alloted to new node.
my $id = 0;

# traverse(Hash, Parent Id)
# Traverses the tree recursively. Prints the information about the current node
# to Standard Output. Call all its child with Parent Id equal to current Node Id.
sub traverse($$)
{
	my ( $ref , $parent ) = @_;
	my %node = %$ref;
	return if $node{ empty };
	$id++;
	my $curr_id = $id;
	print "$parent--$id;\n";
	my $label = "";
	@keys = sort grep {!/^childs/} keys %node;
	foreach $key ( @keys )
	{
		$label .= $key."=>";
		if(ref( $node{ $key }) eq 'ARRAY')
		{
			$label .= join(" ",@{$node{$key}})."\n";
		}
		else
		{
			$label .= $node{$key}." ";
		}
	}
	print "$curr_id [label=\"$label\"];";
	if( $node{childs} )
	{
		my $val1 = $node{childs};
		foreach $child (@$val1)
		{
			traverse( $child, $curr_id );
		}
	}
}

# recursesubdirs( Tree Reference)
# Recurse into sub directories to generate AST 
sub recursesubdirs($)
{
	my ( $ref ) = @_;
	my %node = %$ref;
	if( scalar @{ $node{childs} } == 2)
	{
		my $subdirRef = $node{childs} -> [1];
		my %subdirNode = %$subdirRef;
		foreach $val ( @{ $subdirNode{subdirs} } )
		{
			system( "parser.pl $basedir/$val/Makefile.am > $basedir/$val/ast.gv" );
			system( "unflatten -f -l 10 -c 10 -o $basedir/$val/ast1.gv $basedir/$val/ast.gv" );
			system( "dot -Tpng $basedir/$val/ast1.gv > $basedir/$val/ast.png" );
			system( "rm $basedir/$val/ast.gv $basedir/$val/ast1.gv" );
		}
	}
}
1;