#!/usr/bin/env perl

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

package Common;

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

package CoreDist;

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

sub pathmod
{
	my($p) = @_;
	for ($p){
		s{^lib/}{};
		s{[.]pm$}{};
		s{/}{::}g;
	}
	return $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;
	for my $ddir (map { "$distroot/$_" } @dists){
		for("$ddir/lib"){
			$ddir = $_ if(-d $_);
		}
		my $finder = sub {
			return unless(/[.]pm$/);
			return if(m{/t/});
	
			my $p = $_;
			s{^\Q$ddir\E/}{};
			my $m = pathmod($_);
	
			my $v = findver($p, $m);
			if($v){
				push @found, [ $m, $v ];
			}else{
				#warn "failed to find version in $p\n";
			}
		};
		findfile({ 'no_chdir' => 1, 'wanted' => $finder }, $ddir);
	}

	return @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;
*findver = *main::findver;

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($mod, $ctime) = @$modfile;
		next if $ctime - $oldest > 5; # ignore newer files

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

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

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

package main;

sub findver
{
	my($path, $mod) = @_;

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

	my $m = ($mod
		? qr/(?:\$${mod}::VERSION|\$VERSION)/
		: qr/\$VERSION/);

	while(<$fh>){
		next unless(/\s*$m\s*=\s*.+/);
		chomp;
		my $ver = do { no strict; eval };
		return $ver unless($@);
		die qq{$path:$. bad version string "$_"\n};
	}

	close($fh);
	return undef;
}

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