#!/usr/local/bin/perl
#
# $Id: source2dot,v 1.3 2009/08/02 11:44:19 ryo Exp $
#
use strict;
use warnings;
use Getopt::Std;
use Path::Class::File;
use Data::Dumper;

sub usage {
	die <<__USAGE__;
usage: source2dot [options] source [...]
	-a	show all reference (included out of source)
__USAGE__
}

my @reserved = qw(
	asm auto break case char const continue default define defined do double
	elif else endif enum extern float for goto if ifdef ifndef include inline int
	long pragma register return short signed sizeof static struct switch
	typedef typeof undef union unsigned void volatile while
);

my %opts;
getopts('ah', \%opts);

my @files = @ARGV;


my $graph;
for my $file (@files) {
	(my $source = $file) =~ s,.*/,,;
	$graph->{$source} = source2ref($file);
}

print <<__HEADER__;
digraph G {
	ranksep=3;
	overlap=orthoxy;
	model=shortpath;
	splines=true;
__HEADER__

my %all_declaration;
while (my ($file, $decl) = each %$graph) {

	(my $dummy = $file) =~ s/\W/_/g;
	print qq'	subgraph cluster_$dummy {\n';
	print qq'		style=filled;\n';
	print qq'		label = "$file";\n';

	while (my ($func, $refs) = each(%$decl)) {
		$all_declaration{$func}++;

		if (exists($refs->{__SOURCE2DOT_BLOCKSIZE__})) {
			my $size = $refs->{__SOURCE2DOT_BLOCKSIZE__} / 1024;
			$size = 1 if ($size < 0);
			my $fontsize = $size * 8;
			$fontsize = 12 if ($fontsize < 12);
			print "		$func [ fontsize = $fontsize, width = $size, height = $size];\n";
		} else {
			print "		$func;\n";
		}


	}
	print "	}\n\n";
}


while (my ($file, $decl) = each %$graph) {
	while (my ($func, $refcnt) = each(%$decl)) {
		while (my ($reference, $count) = each(%$refcnt)) {
			next if ($reference =~ m/^__SOURCE2DOT_/);

			if ($opts{a} || exists($all_declaration{$reference})) {
#				print qq'\t$func -> $reference [ label = "$count" ];\n';
				print qq'\t$func -> $reference;\n';
			}
		}
	}
}



print <<__FOOTER__;
}
__FOOTER__




sub extract_functions {
	my $body = shift;
	my $nest = shift;
	my @result;

	return if (!defined($body) or ($body eq ''));

	my $re_symbol = qr/[_A-Za-z]\w*/;
	my $re_paren; $re_paren = qr/\([^()]*(?:(??{$re_paren})[^()]*)*\)/;

	while ($body =~ /($re_symbol)\s*($re_paren)/sg) {
		my $funcname = $1;
		if ($2 ne '') {
			(my $args = $2) =~ s/\n//sg;

			push(@result, $funcname);
			push(@result, extract_functions($args, $nest+1));
		}
	}

	@result;
}


sub source2ref {
	my $path = shift;
	my $file = new Path::Class::File $path;
	my $refcount;


	my $body = $file->slurp();
	$body =~ s,/\*.*?\*\/,,sg;	# delete comment /* ... */
	$body =~ s,//.*,,mg;		# delete comment //


	my $re_symbol = qr/[_A-Za-z]\w*/;
	my $re_paren; $re_paren = qr/\([^\(\)]*(?:(??{$re_paren})[^\(\)]*)*\)/;
	my $re_block; $re_block = qr/\{[^\{\}]*(?:(??{$re_block})[^\{\}]*)*\}/;

	while ($body =~ /($re_symbol)\s*${re_paren}[^()]*?($re_block)/sg) {
		my $funcname = $1;
		my $block = $2;

		next if (grep { $_ eq $funcname } @reserved);

		$refcount->{$funcname}->{__SOURCE2DOT_BLOCKSIZE__} = length($block);

		for my $callee (extract_functions($block, 0)) {
			next if (grep { $_ eq $callee } @reserved);
			$refcount->{$funcname}->{$callee}++;
		}

	}

	$refcount;
}