#!/usr/bin/env perl

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

package CoreDist;

use File::Basename qw(basename);
use File::Find qw();
*findfile = *File::Find::find;
*grokver = *main::grokver;

sub findpmfiles
{
	my($ddir) = @_;

	my @paths;
	my $finder = sub {
		return unless(/[.]pm$/);
		return if(m{/t/});
		push @paths, $_;
	};

	findfile({ 'no_chdir' => 1, 'wanted' => $finder }, $ddir);
	return @paths;
}

sub solopm
{
	my($ddir) = @_;
	my $p = $ddir;
	$p =~ s{.+/}{};

	my $m = $p;
	$m =~ s{-}{::}g;
	$p =~ s{.+-}{};
	$p = "$ddir/$p.pm";

	return (-f $p ? [ $m, $p ] : undef);
}

sub findpms # a foolhardy task!
{
	my($ddir) = @_;
	return findpmfiles($ddir);
}

sub findpl
{
	my($p) = @_;
	my $d = $p;
	$d =~  s{.+/}{};
	$d =~ s{.+-}{};
	$p = "${p}/${d}_pm.PL";
	return (-f $p ? $p : ());
}

# scans a directory full of nicely separated dist. directories.
sub scan_distroot
{
	my ($distroot) = @_;
	opendir my $cpand, "$distroot" or die("failed to open $distroot");
	my @dists = grep { !/^[.]/ && -d "$distroot/$_" } readdir $cpand;
	closedir $cpand;

	my @found = map {
		my $ddir = $_;
		(findpl($ddir), findpms($ddir));
	} map { "$distroot/$_" } @dists;

	return map {
		my($m, $v) = grokver($_);
		($m ? [ $m, $v ] : ());
	} @found;
}

sub findmods
{
	my($srcdir) = @_;
	return map { scan_distroot($_) } glob "$srcdir/{cpan,dist,ext}";
}

# ----------------------------------------

package CoreLib;

use File::Find qw();
use File::stat;

*findfile = *File::Find::find;
*grokver = *main::grokver;

sub findmods
{
	my($srcdir) = @_;
	my $libdir = "$srcdir/lib/";
	die "failed to find $libdir directory" unless(-d $libdir);

	# Find only the module files that have not changed since perl
	# was extracted. We don't want the files perl just recently
	# installed into lib/. We processed those already.
	my @modfiles;
	my $finder = sub {
		return unless(/[.]pm\z/);
		return if m{\Q$libdir\E[^/]+/t/}; # ignore testing modules
		push @modfiles, $_;
	};
	findfile({ 'no_chdir' => 1, 'wanted' => $finder }, $libdir);

	# First we have to find what the oldest ctime actually is.
	my $oldest = time;
	@modfiles = map {
		my $modfile = $_;
		my $ctime = (stat $modfile)->ctime;
		$oldest = $ctime if($ctime < $oldest);
		[ $modfile, $ctime ]; # save ctime for later
	} @modfiles;

	# Then we filter out any file that was created more than a
	# few seconds after that. Process the rest.
	my @mods;
	for my $modfile (@modfiles){
		my($path, $ctime) = @$modfile;
		next if $ctime - $oldest > 5; # ignore newer files

#		my $mod = $path;
#		$mod =~ s{[.]pm\z}{};
#		$mod =~ s{\A$libdir}{};
#		$mod =~ s{/}{::}g;

		my($mod, $ver) = grokver($path);
		if($mod){
			push @mods, [ $mod, $ver ];
		}else{
			warn "failed to find version in $path\n";
		}
	}
	return @mods;
}

# ----------------------------------------

package main;

sub grokver
{
	my($path) = @_;

	open(my $fh, '<', $path) or die("open $path: $!");

	my $m = qr/\$VERSION/;
	my $pkg;
	while(<$fh>){
		if(/^\s*package\s+([\w:_-]+)\s*;/){
			$pkg = $1;
			$m = qr/\$${pkg}::VERSION|\$VERSION/;
		}elsif($pkg && /\s*$m\s*=\s*.+/){
			chomp;
			my $ver = do { no strict; eval };
			if($@ || !defined $ver || $ver eq q{}){
				warn qq{$path:$.: bad version string: $_\n};
				return ();
			}else{
				#print STDERR "DBG: grokked $pkg - $ver from $path\n";
				return ($pkg, $ver);
			}
		}
	}

	close($fh);
	return ();
}

sub delmods
{
	my $coreonly = shift;
	for(@_){
		my($m) = split;
		delete $coreonly->{$m};
	}
	return;
}

sub nocpan
{
	my($mods, $mpath) = @_;
	my %coreonly = map { @$_ } @$mods;

	# Remove mods from the set which are also available from CPAN.
	local $/ = qq{\n\n};
	open my $if, '<', $mpath or die "open $mpath failed: $!";
	while(<$if>){
		my(undef, @dms) = split /\n/;
		delmods(\%coreonly, @dms);
	}
	close $if;

	return \%coreonly;
}

sub printmods
{
	my($mods, $mpath) = @_;
	my $coreonly = nocpan($mods, $mpath);

	# Print a * in the third column for core-only modules.
	for my $mv (@$mods){
		my($m, $v) = @$mv;
		printf "%s\n", join q{ }, $m, $v, ($coreonly->{$m} ? q{*} : ());
	}

	return;
}

sub main
{
	die"Usage: $0 [path to perl source] [path to cpan.mods]\n" unless(@_ == 2);
	my($perldir, $mpath) = @_;

	die "$perldir is not a valid directory.\n" unless(-d $perldir);
	die "$mpath is not a valid file.\n" unless(-f $mpath);

	my @mods = (CoreDist::findmods($perldir), CoreLib::findmods($perldir));

	## Embedded modules without any files...
	push @mods, [ 'Config' => 1 ];

	@mods = sort { $a->[0] cmp $b->[0] } @mods;
	printmods(\@mods, $mpath);

	return 0;
}

exit main(@ARGV);