#!/usr/bin/perl
#
# licenced under the same terms as perl itself
#
# AUTHOR: David Cantrell
# Co-author: Walery Studennikov <despair@regtime.net>

use strict;
use Text::Balanced 'extract_codeblock';
$|=1;

my $debug=0;
my $ignorpkg=0;
my $use_deparse=0;
my $rep_all=1;
my $rep_subs=0;
my $rep_files=0;
my $rep_subs=0;
my $rep_calls=0;
my $rep_callers=0;
my @files=();

if(!@ARGV) {
	die("
--debug to turn debugging on
--ignorpkg to ignore packages when finding dependencies
--all - all reports (default)
--subs - list of subroutines, and the files that define them
--files - list of files, and the subroutines defined therein
--calls - list of subs, and the subroutines called therefrom
--callers - list of subs, and the subroutines which call \'em
--deparse - use B::Deparse for processing modules
Gimme a list of files to look at.
If you want any more docs, use the source\n");
}

foreach my $arg (@ARGV) {
	if($arg eq '--debug') { $debug=1; warn "Debugging mode turned on.\n"; }
	elsif($arg eq '--ignorpkg') { $ignorpkg=1; }
	elsif($arg eq '--all') { $rep_all=1; }
	elsif($arg eq '--subs') { $rep_subs=1; $rep_all=0; }
	elsif($arg eq '--files') { $rep_files=1; $rep_all=0; }
	elsif($arg eq '--calls') { $rep_calls=1; $rep_all=0; }
	elsif($arg eq '--callers') { $rep_callers=1; $rep_all=0; }
	elsif($arg eq '--deparse') { $use_deparse=1; }
	else { push @files,$arg; }
}
die("No files specified.\n") unless(@files);

my %subsByFiles=();
my %filesContainingSubs=();
my %subsByCaller=();
my %callersBySub=();
my @allSubsDefined=();
my %warnings=();
my %severe_warnings=();

# Find subroutine definitions

foreach my $file (@files) {
	if ($use_deparse) {
	    warn "\nDeparsing $file\n";
	    (my $newfile = $file) =~ s/\//_/;
	    $newfile = "/tmp/tmp_$newfile";
	    system("perl -MO=Deparse $file > $newfile") == 0
		or die "Can't deparse $file: $!\n";
	    $file = $newfile;
	} else {
	    warn "\n";
	}

	open(FILE,$file) || ($warnings{"Couldn't open file $file."}++ && next);
	warn "Reading $file\n";
	my $inPOD = 0;

	# read file, cutting out any nasty POD
	# FIXME remove double-quotish stuff.  Requires Parse::Perl :-)
	my $remainder = join('', map {
		if($_ =~ /^=(head[1-4]?|over|item|back|pod|begin|end|for)/) {
			$inPOD = 1;
		} elsif(substr($_,0,4) eq '=cut') { $inPOD = 0; $_ = '' }
		($inPOD)?undef:$_;
	} <FILE>);
	close(FILE);

	my $package='main';
	my @subsInThisFile=();

	
	while($remainder) {
		if($remainder=~/^sub\s/) {
			my $sub={};
			$remainder=~s/^sub\s+([a-z0-9_]+)\s*(?:\([@%$;\\\s]*\)\s*)?//i;
			my $subName = $1 or next;

			my $fullName=$package.'::'.$subName;
			warn "  Debug: found sub $fullName\n" if($debug);
			print STDERR '.' unless($debug);
			my $subBody;
			if ($use_deparse) {
				$remainder =~ s/(^\{.*?\n\})//s;
				$subBody = $1;
			} else {
				($subBody,$remainder)=extract_codeblock($remainder,'{}');
			}
			if($@) {
				warn "  Wierdness in $file: $@\n  (I think the current sub is $fullName)\n" if($debug);
			} else {
				$sub->{shortname}=$subName;
				$sub->{name}=$fullName;
				$sub->{body}=$subBody;
				push @subsInThisFile,$sub;
			}
		} elsif($remainder=~/^package\s+[\w:]+;/) { # look for "package foo::bar;"
			$remainder=~s/^package\s+([a-z0-9_:]+)\s*//i;
			$package=$1;
			warn "Debug: in package $package\n" if($debug);
		} elsif(substr($remainder,0,7) eq '__END__') {
			last;
		} else {
			unless ($remainder =~ s/^[^ps_]+//) {
			    substr($remainder,0,1) = '';
			};
		}
	}
	foreach my $sub (@subsInThisFile) {
		if(ref($filesContainingSubs{$sub->{name}})) {
			$warnings{"$sub->{name} might be redefined"}++;
		}
		push @allSubsDefined, $sub unless(contains([map { $_->{name} } @allSubsDefined], $sub->{name}));

		$filesContainingSubs{$sub->{name}}=[] unless(ref($filesContainingSubs{$sub->{name}}));
		$subsByFiles{$file}=[] unless(ref($subsByFiles{$file}));

		$filesContainingSubs{$sub->{name}}=[ @{$filesContainingSubs{$sub->{name}}}, $file ];
		warn "Inserted $file into $sub->{name}.\n" if($debug);
		if(contains([map { $_->{name} } @{$subsByFiles{$file}}], $sub->{name})) {
			$severe_warnings{"$sub->{name} looks like it's redefined within $file"}++;
		}
		$subsByFiles{$file}=[ @{$subsByFiles{$file}}, $sub ];
	}
}

warn "\nFinding dependencies...\n";

#my @allSubNamesDefined=map { $ignorpkg ? $_->{shortname} : $_->{name} } @allSubsDefined;

# now the fun bit, find subs called by each sub and populate two data structures so
# we can go both ways - find which subs call sub X and which subs are called by X.

foreach my $sub (@allSubsDefined) {
	my($fullName, $body)=($sub->{name}, $sub->{body});
	warn "Finding subs called by $fullName ...\n" if($debug);
	$fullName=~/^(.+)::([^:]+?)$/;
	my($package, $subName)=($1, $2);

	# Extract the list of subs called from this sub ...
	# This is not 100% accurate.  eg, it fucks up if a
	#   sub name appears in a comment or in quoted text.
	my @subsCalledByThisSub;
	foreach ($body =~ m/(?:[^a-z0-9_:])([a-z0-9_:]+)(?:[^a-z0-9_:])/gi) { # m matches stuff which might be a sub call
	    my $sub = ($ignorpkg || index($_,'::')>0) ? $_ : $package.'::'.$_;
	    foreach (@allSubsDefined) {
		if(($ignorpkg ? $_->{shortname} : $_->{name}) eq $sub) {
		    push @subsCalledByThisSub, $_->{name};
		};
	    }
	}

	# Now we unique-ify the list ...
	my %unique=map { $_,0 } @subsCalledByThisSub; @subsCalledByThisSub=keys %unique;

	$subsByCaller{$fullName}=\@subsCalledByThisSub;
	foreach my $calledSub (@subsCalledByThisSub) {
		$callersBySub{$calledSub}=[] unless(ref($callersBySub{$calledSub}));
		$callersBySub{$calledSub}=[@{$callersBySub{$calledSub}}, $fullName]
			unless(contains($callersBySub{$calledSub}, $fullName));
	}
}

warn "\nMaking reports...\n";

# Boring-ness abounds as we just spew the crap back out again

foreach my $severe_warning (sort keys %severe_warnings) {
	print "Severe Warning ($severe_warnings{$severe_warning} times): $severe_warning\n";
}
foreach my $warning (sort keys %warnings) {
	print "Warning ($warnings{$warning} times): $warning\n";
}

if ($rep_subs || $rep_all) {
    print "Alphabetical list of subroutines, and the files that define them ...\n\n";
    foreach my $sub (sort keys %filesContainingSubs) {
	$sub=~/^(.*)::(.*?)$/; my($package, $subName)=($1, $2);
	print "$sub\n";
	foreach my $file (sort @{$filesContainingSubs{$sub}}) {
		print "  $file\n";
	}
    }
}

if ($rep_files || $rep_all) {
    print "\nAlphabetical list of files, and the subroutines defined therein ...\n\n";
    foreach my $filename (sort keys %subsByFiles) {
	print "$filename:\n";
	foreach my $sub (sort {
		lc((reverse split('::', $a->{name}))[0]) cmp lc((reverse split('::', $b->{name}))[0]);
	} @{$subsByFiles{$filename}}) {
		# $sub->{name}=~/^(.*)::(.*?)$/; my($package, $subName)=($1, $2);
		# print "  $subName (in package $package)\n";
		print "  $sub->{name}\n";
	}
    }
}

if ($rep_calls || $rep_all) {
    print "\nAlphabetical list of subs, and the subroutines called therefrom ...\n\n";
    foreach my $caller (sort keys %subsByCaller) {
	print "$caller\n" if(ref($subsByCaller{$caller}));
	foreach my $calledSub (sort @{$subsByCaller{$caller}}) {
		# $calledSub=~/^(.*)::(.*?)$/; my($package, $subName)=($1, $2);
		# print "  $subName (in package $package)\n";
		print "  $calledSub\n";
	}
    }
}

if ($rep_callers || $rep_all) {
    print "\nAlphabetical list of subs, and the subroutines which call 'em ...\n\n";
    foreach my $called (sort keys %callersBySub) {
	print "$called\n" if(ref($callersBySub{$called}));
	foreach my $callingSub (sort @{$callersBySub{$called}}) {
		# $callingSub=~/^(*)::(.*?)$/; my($package, $subName)=($1, $2);
		# print "  $subName (in package $package)\n";
		print "  $callingSub\n";
	}
    }
}

sub contains {
	my @list=@{+shift};
	my $item=shift;
	foreach my $i (@list) { return 1 if($i eq $item); }
	return 0;
}