path: root/misc/perlcore

#!/usr/bin/env perl

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

package Common;

sub evalver
{
	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;
}

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

package CoreDist;

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

sub modname
{
	my($dist) = @_;
	$dist =~ s/-+/::/g;
	return $dist;
}

sub maindistfile
{
	my($dist, $dir) = @_;

	# libpath is the modern style, installing modules under lib/
	# with dirs matching the name components.
	my $libpath = join(q{/}, 'lib', split(/-/, "${dist}.pm"));

	# dumbpath is an old style where there's no subdirs and just
	# a .pm file.
	my $dumbpath = $dist;
	$dumbpath =~ s/\A.+-//;
	$dumbpath .= ".pm";

	my @paths = ($libpath, $dumbpath);
	# Some modules (with simple names like XSLoader, lib, etc) are
	# generated by Makefile.PL. Search through their generating code.
	push @paths, "${dist}_pm.PL" if($dist =~ tr/-/-/ == 0);

	for my $path (map { "$dir/$_" } @paths){ return $path if(-f $path); }
	return undef;
}

sub module_ver
{
	my($dist, $dir) = @_;

	my $path = maindistfile($dist, $dir) or return undef;

	my $mod = modname($dist);
	my $ver = Common::evalver($path, $mod);
	unless($ver){
		warn "failed to find version in module file $path\n";
		return undef;
	}

	return [ $mod, $ver ];
}

sub changelog_ver
{
	my($dist, $dir) = @_;

	my $path;
	for my $tmp (glob "$dir/{Changes,ChangeLog}"){
		if(-f $tmp){ $path = $tmp; last; }
	}
	return undef unless($path);

	my $mod = modname($dist);
	open my $fh, '<', $path or die"open: $!";
	while(<$fh>){
		return [ $mod, $1 ] if(/\A\s*(?:$dist[ \t]*)?([0-9._]+)/);
		return [ $mod, $1 ] if(/\A\s*version\s+([0-9._]+)/i);
	}
	close $fh;

	return undef;
}

# for some reason podlators has a VERSION file with perl code in it
sub verfile_ver
{
	my($dist, $dir) = @_;
	my $path = "$dir/VERSION";
	return undef unless(-f $path); # no warning, only podlaters has it

	my $v = Common::evalver($path);
	return ($v ? [ modname($dist), $v ] : undef);
}

# 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){
		$ddir .= 'lib/' if(-d "$ddir/lib");
		my $finder = sub {
			return unless(/[.]pm$/);
			return if(m{/t/});
	
			my $p = $_;
			s/^\Q$ddir\E//;
			s{^lib/}{};
			s{[.]pm$}{};
			s{/}{::}g;
			my $m = $_;
	
			my $v = Common::evalver($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}";
}

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

package CoreLib;

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

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

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 = Common::evalver($path, $mod);
		if($ver){
			push @mods, [ $mod, $ver ];
		}else{
			warn "failed to find version in $path\n";
		}
	}
	return @mods;
}

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

package main;

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

sub printmods
{
	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($dist, @dms) = split /\n/;
			_delmods(\%coreonly, @dms);
		}
		close $if;
	}

	# 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{*} : ());
	}
}

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