#!/pro/bin/perl

use 5.18.2;
use warnings;

our $VERSION = "0.02 - 20181015";
our $CMD = $0 =~ s{.*/}{}r;

sub usage {
    my $err = shift and select STDERR;
    say "usage: $CMD [-v] [file|folder] ...";
    say "       $CMD --core | --site";
    exit $err;
    } # usage

use Getopt::Long qw(:config bundling);
GetOptions (
    "help|?"		=> sub { usage (0); },
    "V|version"		=> sub { say "$CMD [$VERSION]"; exit 0; },

    "c|core!"		=> \ my $opt_c,
    "s|site!"		=> \ my $opt_s,

    "v|verbose:1"	=> \(my $opt_v = 0),
    ) or usage (1);

use Config;
use Cwd;
use Data::Peek;
use Devel::Examine::Subs;
use Digest::SHA qw(sha256_hex);
use File::Find;
use SourceCode::LineCounter::Perl;
use String::CommonPrefix qw(common_prefix);

my @loc = @ARGV;
$opt_c and push @loc, $Config{privlib};
$opt_s and push @loc, $Config{sitelib};
@loc or @loc = (getcwd);

my %file;
my %seen;
# Find all .pm and .pl files. (no .PL or .xs)
find (sub {
    m/\.p[ml]$/		or  return;
    m/^\./ || -l	and return;	# No symlinks or dot-files
    $File::Find::dir =~ m{\b(?:sandbox|tmp)(?:/|$)} and return;
    $seen{(lstat)[1]}++	and return; # dup on inode (hard-link)
    my $sha = sha256_hex ($_);
    $seen{$sha}++	and return; # dup on SHA
    $file{$File::Find::name} = $sha;
    }, @loc);
my $pfx = common_prefix (keys %file);

my %stats;
for my $file (sort keys %file) {
    $opt_v and say $file;
    my $name = $file =~ s/^$pfx//r;

    my $flc = SourceCode::LineCounter::Perl->new;
    $flc->count ($file);
    $stats{$name} = {
	name  => $name,
	file  => $file,
	lines => $flc->total,
	blank => $flc->blank,
	doc   => $flc->documentation,
	cmnt  => $flc->comment,
	loc   => 0,
	nobj  => 0,
	};

    # Now analyse subs
    my $des  = Devel::Examine::Subs->new (file => $file);
    unless ($des) {
	say STDERR "Cannot analyse $name";
	next;
	}
    my $objs = $des->objects;
    unless ($objs) {
	say STDERR "File $name has no objects";
	next;
	}
    foreach my $obj (@{$des->objects}) {

	$stats{$name}{nobj}++;

	my $slc = SourceCode::LineCounter::Perl->new;
	$slc->count (\do { join "\n" => @{$obj->code} });

	my $loc = $slc->code;
	$stats{$name}{loc} += $loc;

	push @{$stats{$name}{obj}}, {
	    name  => $obj->name,
	    loc   => $loc,
	    lines => $slc->documentation,
	    cmnt  => $slc->comment,
	    blnk  => $slc->blank,
	    doc   => $slc->documentation,
	    };
	}
    }

delete $SIG{__WARN__};
delete $SIG{__DIE__};

my @sum;
say " subs   lines     LOC    doc  blank  File";
say "----- ------- ------- ------ ------  --------------------------------------";
for (sort { $b->{nobj} <=> $a->{nobj} || $b->{loc} <=> $a->{loc} } values %stats) {
    printf "%5d %7d %7d %6s %6d  %s\n",
	$_->{nobj}, $_->{lines}, $_->{loc}, $_->{doc} + $_->{cmnt}, $_->{blank},
	$_->{name};
    $sum[0] += $_->{nobj};
    $sum[1] += $_->{lines};
    $sum[2] += $_->{loc};
    $sum[3] += $_->{doc} + $_->{cmnt};
    $sum[4] += $_->{blank};
    }
say "----- ------- ------- ------ ------  --------------------------------------";
printf "%5d %7d %7d %6s %6d\n", @sum;