#!/usr/bin/perl
#
# licenced under the same terms as perl itself

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

my $debug=0;
my @files=();

if(!@ARGV) {
	die("
-debug to turn debugging on.
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; print "Debugging mode turned on.\n"; }
	 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) {
	open(FILE,$file) || ($warnings{"Couldn't open file $file."}++ && next);
	print "Debug: reading $file\n" if($debug);
	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(substr($remainder,0,7) eq '__END__') {
			last;
		# look for "package foo::bar;"
		} elsif($remainder=~/^package\s+[\w:]+;/) {
			$remainder=~s/^package\s+//;      # chop word 'package' off front
			$remainder=~/^([a-z0-9_:]+)/i;    # get package name ...
			$package=$1;
			$remainder=~s/^$package\s*//;     # chop package name off front
			print "Debug: in package $package\n" if($debug);
		} elsif($remainder=~/^sub\s/) {
			my $sub={};
			$remainder=~s/^sub\s+//;          # chop word 'sub' off the front ...

			my $subName;                            # either get sub name or jump out
			if($remainder=~/^([a-z0-9_]+)/i) { $subName=$1; }
			next unless($subName);

			$remainder=~s/^$subName\s*(\([@%$;\\\s]*\)\s*)?//; # chop sub name and prototype off front

			$subName=$package.'::'.$subName;
			print "  Debug: found sub $subName\n" if($debug);
			print '.' unless($debug);
			my($subBody,$trailingStuff)=extract_codeblock($remainder,'{}');
			if($@) {
				print "  Wierdness in $file: $@\n  (I think the current sub is $subName)\n" if($debug);
			} else {
				$sub->{name}=$subName;
				$sub->{body}=$subBody;
				push @subsInThisFile,$sub;
			}
			$remainder=$trailingStuff;
		} else {
			$remainder=substr($remainder,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 ];
		print "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 ];
	}
}

my $allSubNamesDefined=[map { $_->{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});
	print "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.
	$_=$body; my @subsCalledByThisSub=grep {    # grep throws out anything that we haven't defined
		contains($allSubNamesDefined,$_);
	} map {                                     # map prepends package names if necessary
		$_=$package.'::'.$_ unless(index($_,'::')>0);
		$_;
	} m/(?:[^a-z0-9_:])([a-z0-9_:]+)(?:[^a-z0-9_:])/gi; # m matches stuff which might be a sub call

	# 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));
	}
}

# 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";
}

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";
	}
}

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";
	}
}

print "\nAlphabetical list of subs, and the subroutines called therefrom ...\n\n";
# foreach my $caller (sort {
#	lc((reverse split('::', $a))[0]) cmp lc((reverse split('::', $b))[0]);
# } keys %subsByCaller) {
foreach my $caller (sort keys %subsByCaller) {
	# $caller=~/^(.*)::(.*?)$/; my($package, $subName)=($1,$2);
	# print "$subName (in package $package):\n" if(ref($subsByCaller{$caller}));
	print "$caller\n" if(ref($subsByCaller{$caller}));
	# foreach my $calledSub (sort {
	#	lc((reverse split('::', $a))[0]) cmp lc((reverse split('::', $b))[0]);
	# } @{$subsByCaller{$caller}}) {
	foreach my $calledSub (sort @{$subsByCaller{$caller}}) {
		# $calledSub=~/^(.*)::(.*?)$/; my($package, $subName)=($1, $2);
		# print "  $subName (in package $package)\n";
		print "  $calledSub\n";
	}
}

print "\nAlphabetical list of subs, and the subroutines which call 'em ...\n\n";
# foreach my $called (sort {
#	lc((reverse split('::', $a))[0]) cmp lc((reverse split('::', $b))[0]);
# } keys %callersBySub) {
foreach my $called (sort keys %callersBySub) {
	# $called=~/^(.*)::(.*?)$/; my($package, $subName)=($1,$2);
	# print "$subName (in package $package):\n" if(ref($callersBySub{$called}));
	print "$called\n" if(ref($callersBySub{$called}));
	# foreach my $callingSub (sort {
	#	lc((reverse split('::', $a))[0]) cmp lc((reverse split('::', $b))[0]);
	# } @{$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;
}