#! /usr/bin/perl
#
# dotify - create graph of source code (in dot)
# Copyright (C) 2007 Tommi Saviranta  <wnd@iki.fi>
#
# 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 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

# Ideal usage:
# $ ( echo "digraph map {"; perl dotify.pl source 2>/dev/null \
#	| sort | uniq; echo "}" ) | dot -Tpng | display


use strict;
use warnings FATAL => 'all';


# TODO
#  - internal calls
#  - unresolved calls
#  - pretty much everything else

my $debug = 255;
$debug = 127;
# $debug = 7;
# $debug = 3;

my $show_external = 1;
my $show_internal = 1;


# funcs: map function into header
# $funcs{"foo"} = "bar.h"
my %funcs;
my %i_funcs; # internal functions

# rets: return value of a function
# $rets{"foo"} = "void"
my %rets;

# read header and source files
my %headers;
my %sources; # actually lists all seen sources

# source files in queue
my @src_queue;

my %enums;
my %structs;

# callers: map function callers
# $callers{"myfunc 0"} = "malloc"
# $callers{"myfunc 1"} = "free"
my %callers;




sub dump_stuff() {
	foreach my $header (keys %headers) {
		print STDERR "$header\n";
		while (my ($struct, $file) = each %enums) {
			print STDERR "  s: $struct\n" if ($file eq $header);
		}
		while (my ($func, $file) = each %funcs) {
			print STDERR "  f: $func\n" if ($file eq $header);
		}
		while (my ($enum, $file) = each %structs) {
			print STDERR "  e: $enum\n" if ($file eq $header);
		}
	}
}


# 0: file
# 1: buffer
# r: new buffer
sub parse_header_func($$) {
	my ($file, $buf) = @_;
	($buf =~ /^\s/) && return "";
	my ($ret, $name) = $buf =~ /(.*?\s?\**)\s*([^\s]+)\(/;
	(defined($ret) && defined($name)) || return $buf;
	$ret =~ s/\s+$//;
	print STDERR "function ($ret) ($name)\n" if ($debug & 16);
	$funcs{$name} = $file;
	$rets{$name} = $ret;
	return "";
}


# 0: file
# 1: func
# 2: buffer
# r: new buffer
sub parse_source_func($$$) {
	my ($file, $func, $buf) = @_;
	my ($cand) = $buf =~ /\s([a-zA-Z_]+)\(/;
	(defined($cand)) || return $buf;

	my $origin = $funcs{$cand};
	my ($src_file, $dst_file);
	$src_file = $file;
	$src_file =~ s/\.h/.c/;
	if (defined($origin)) {
		$dst_file = $origin;
		$dst_file =~ s/\.h/.c/;
	}

#	print "$buf\n";
	if ($func eq $cand || defined($dst_file) && $dst_file eq $src_file) {
#		print STDERR "internal call: $func -> $cand\n";
	} elsif (! defined($origin)) {
#		print STDERR "unresolved call: $func -> $cand\n"
	} else {
		# files always have .c suffix
		print STDERR "$func -> $origin ($cand)\n";
		print "\"$src_file\" -> \"$dst_file\" [label=\"$cand\"];\n";
	}
	return "";
}


# 0: file
# 1: buffer
# 2: is_header
# r: new buffer
sub parse_struct($$) {
	my ($file, $buf, $is_header) = @_;
	($buf =~ /^\s/) && return "";
	my ($name) = $buf =~ /struct ([^ ]*?)\s+\{/;
	(defined($name)) || return $buf;
	$structs{$name} = $file;
	print STDERR "struct   ($name)\n" if ($debug & 16);
	return "";
}


# 0: file
# 1: buffer
# 2: is_header
# r: new buffer
sub parse_enum($$$) {
	my ($file, $buf, $is_header) = @_;
	($buf =~ /^\s/) && return "";
	my ($name) = $buf =~ /enum ([^ ]*?)\s+\{/;
	(defined($name)) || return $buf;
	$enums{$name} = $file;
	print STDERR "enum     ($name)\n" if ($debug & 16);
	return "";
}


# 0: file
# 1: is header
sub process_file($) {
	my ($file, $is_header) = @_;
	my $handle;
	open($handle, "< $file") or die "Cannot read \"$file\": $!";
	my $in = 0;
	my $buf = "";
	# $comment is buggy. it doesn't know literals.
	my $comment;
	my $func;

	while (<$handle>) {
		my $in_was = $in;
		chop;

		while (/\/\*/) {
			my $t;
			($t, $_) = /(.*?)\/\*(.*)/;
			$comment = 1;
			if (/\*\//) {
				s/.*?\*\///;
				$_ = $t . $_;
				$comment = 0;
			}
		}
		if (/\*\//) {
			s/.*?\*\///;
			$comment = 0;
		}
		/\/\// && s/\/\/.*//;

		($comment == 1) && next;

		$in++ if (/\{/);
		$in-- if (/\}/);

		print STDERR "< $_\n" if ($debug & 128);

		if ($in_was == 0 && /^#\s*include "/) {
			my ($file) = /.*?include "(.*?)"/;
			if (! defined($sources{$file})) {
				$sources{$file} = 1;
				my $source = $file;
				$source =~ s/\.h/\.c/;
				if (-e $source) {
					push(@src_queue, $source);
					print STDERR "queue: $source\n";
				}
			}
			&process_file($file, 1);
			next;
		} elsif (/^#/) {
			next;
		} elsif ($in_was == 0 && /^typedef /) {
			print STDERR "typedef: $_\n";
			next;
		} elsif ($in_was == 0 && /^enum.*\{/) {
			$buf .= " " if ($buf =~ /./);
			$buf .= $_;
			$buf = &parse_enum($file, $buf, $is_header);
			next;
		} elsif ($in_was == 0 && /^struct.*\{/) {
			$buf .= " " if ($buf =~ /./);
			$buf .= $_;
			$buf = &parse_struct($file, $buf, $is_header);
			next;
		} elsif (/^\s*$/) {
			next;
		} elsif ($in_was == 0) {
			$buf .= " " if ($buf =~ /./);
			$buf .= $_;
			if ($is_header == 1) {
				$buf = &parse_header_func($file, $buf);
			} else {
				my ($cand) = /^([a-zA-Z_]+)\(/;
				if (defined($cand)) {
					$func = $cand;
					print STDERR "func: $func\n";
				}
			}
		} else {
			$buf .= " " if ($buf =~ /./);
			$buf .= $_;
			if ($is_header == 0) {
				$buf = &parse_source_func($file, $func, $buf);
			}
		}
	}
	close($handle);
	$headers{$file} = 1;
	print STDERR "$file\n" if ($debug & 4);
}


push(@src_queue, $ARGV[0]);
while ($#src_queue >= 0) {
	my $file = pop @src_queue;
	print STDERR "$file\n" if ($debug & 2);
	&process_file($file, 0);
}

#&dump_stuff();