Adds perl.d/scrapecore script to find core-only modules in perl source.

1 files changed, 237 insertions, 0 deletions

diff --git a/lib/metas/perl.d/scrapecore b/lib/metas/perl.d/scrapecore
new file mode 100644
index 0000000..eae1b21
--- /dev/null
+++ b/lib/metas/perl.d/scrapecore
@@ -0,0 +1,237 @@
+#!/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($@);
+		warn(qq{$path:$. bad version string "$_"\n});
+	}
+
+	close($fh);
+	return undef;
+}
+
+# ----------------------------------------
+
+package CoreDist;
+use File::Basename qw(basename);
+
+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 $dist (@dists){
+		my $distdir = "$distroot/$dist";
+		my $mv = (module_ver($dist, $distdir)
+				   || changelog_ver($dist, $distdir)
+				   || verfile_ver($dist, $distdir));
+
+		if($mv){ push @found, $mv; }
+		else { warn "failed to find version for $dist\n"; }
+	}
+	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;
+
+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/);
+		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) || q{};
+		push @mods, [ $mod, $ver ];
+	}
+	return @mods;
+}
+
+# ----------------------------------------
+
+package main;
+
+sub _delmatch
+{
+	my ($mvs, $findus) = @_;
+	for (@$mvs){
+		my ($m) = split;
+		delete($findus->{$m});
+	}
+	return;
+}
+
+sub coreonly
+{
+	my (%mods) = map { @$_ } @_;
+	my $path = "$ENV{'PKGVAR'}/cpanmods";
+	open(my $if, '<', $path) or die("open $path: $!");
+
+	my @dists;
+	local $/ = qq{\n\n};
+	while(<$if>){
+		last unless(%mods);
+		my ($dist, @dms) = split(/\n/);
+		next if(defined delete $mods{$dist});
+		_delmatch(\@dms, \%mods);
+	}
+
+	close($if);
+	my @core;
+	for my $k (keys %mods) {
+		push(@core, [ $k, $mods{$k} ]);
+	}
+	return sort { $a->[0] cmp $b->[0] } @core;
+}
+
+my $perldir = shift or die("Usage: $0 [path to perl source directory]\n");
+die("$perldir is not a valid directory.\n") unless(-d $perldir);
+
+my @mods =
+	(CoreDist::findmods($perldir),
+	CoreLib::findmods($perldir));
+
+@mods = coreonly(@mods);
+for my $mv (@mods){ print "@$mv\n"; }