Move metas/ and templ/ under ~/.genpkg.

4 files changed, 991 insertions, 0 deletions

diff --git a/metas/perl b/metas/perl
new file mode 100755
index 0000000..4b61175
--- /dev/null
+++ b/metas/perl
@@ -0,0 +1,106 @@
+#!/usr/bin/env perl
+
+use warnings 'FATAL' => 'all';
+use strict;
+
+use File::Fetch;
+use IO::Handle; # for autoflush
+use Cwd;
+
+my $PROG = 'metas/perl';
+my %BADNAMES = ('perl-libwww' => 'libwww-perl');
+
+sub err
+{
+	print STDERR "$PROG: ", @_, "\n";
+	exit 1;
+}
+
+sub matchdist
+{
+	my($dist) = @_;
+
+	# Refresh our local list of distributions if needed.
+	my $var = $ENV{'PKGVAR'}
+		or err('PKGVAR env variable is unset');
+
+	if(!-f "$var/cpandists" || -M "$var/cpandists" > 1) {
+		print STDERR "$PROG: Refreshing local CPAN data... ";
+		my $cwd = getcwd();
+		chdir $var or die "chdir: $!";
+		system 'fetchcpan';
+		die "FAILED\n" unless($? == 0);
+		print STDERR "OK\n";
+		chdir $cwd or die "chdir: $!";
+	}
+
+	open(DISTS, '<', "$var/cpandists") or err("open: $!");
+	while(<DISTS>) {
+		my @f = split;
+		my $d = lc $f[0]; $d =~ tr/-_/--/s;
+		next unless($d eq lc($dist));
+		close(DISTS);
+		return ($f[0], $f[2]);
+	}
+	close(DISTS);
+	return ();
+}
+
+sub fetchdist
+{
+	my($cpath) = @_;
+	my $file = $cpath; $file =~ s{^.*/}{};
+	if(-f $file) {
+		print STDERR "$file already downloaded.\n";
+		return;
+	}
+
+	my $mirror = $ENV{'CPANMIRROR'} || 'ftp://cpan.pair.com';
+	my $url = "${mirror}/authors/id/${cpath}";
+
+	print STDERR "Downloading $file... ";
+	my $ff = File::Fetch->new('uri' => $url);
+	die "FAILED\n" unless($ff->fetch());
+	print STDERR "OK\n";
+}
+
+sub main
+{
+	my $dist = shift or die "usage: $PROG [package name]\n";
+
+	my $guess;
+	if($BADNAMES{$dist}){
+		$dist = $BADNAMES{$dist};
+	}elsif($dist =~ s/^perl-// == 0){
+		$guess = 1;
+		$dist = "app-$dist";
+	}
+
+	STDERR->autoflush(1);
+	my ($realname, $cpath) = matchdist($dist);
+	unless($realname){
+		if($guess){
+			return 2
+		}else{
+			## Return a hard error to makepkgmeta if perl- package.
+			err(qq{failed to find perl dist similar to '$dist'});
+			return 1
+		}
+	}
+	fetchdist($cpath);
+
+	print <<"END_META";
+url
+https://metacpan.org/release/$realname
+
+source
+http://search.cpan.org/CPAN/authors/id/$cpath
+
+END_META
+
+	my $file = $cpath; $file =~ s{.*/}{};
+	system 'perl-dist' => $file;
+	return $?;
+}
+
+exit main(@ARGV);
diff --git a/metas/perl.d/fetchcpan b/metas/perl.d/fetchcpan
new file mode 100755
index 0000000..076599b
--- /dev/null
+++ b/metas/perl.d/fetchcpan
@@ -0,0 +1,60 @@
+#!/bin/sh
+
+mirror=${CPANMIRROR:-ftp://cpan.pair.com}
+path=/modules/02packages.details.txt.gz
+
+curl --silent "$mirror$path" | gzip -dc | awk '
+NR < 10 { next }
+{
+    file = a[split($3, a, "/")]
+
+    if (!match(file, /[-_][vV]?[0-9]+/)) {
+        #print "error: failed to grok " $3 | "cat 1>&2"
+        next
+    }
+    ver  = substr(file, RSTART+1)
+    dist = substr(file, 1, RSTART-1)
+
+    sub(/[.]tar[.].*$|[.]zip$/, "", ver)
+    sub(/^[vV]/, "", ver)
+    sub(/[.]pm$/, "", dist)
+
+    if(dist == "perl") next
+
+    mods[dist,ver] = mods[dist,ver] $1 " " $2 "\n"
+    if (lessthan(dists[dist], ver)) {
+        dists[dist] = ver
+        paths[dist] = $3
+    }
+}
+
+END {
+    for (dist in dists) {
+        ver = dists[dist]
+        print dist, ver, paths[dist] | "sort >cpandists"
+    }
+    close("sort >cpandists")
+
+    # Prints modules out in sorted order, too!
+    while(getline<"cpandists" > 0) {
+        print $1 "\n" mods[$1,$2] >"cpanmods"
+    }
+}
+
+function lessthan (l, r)
+{
+    return decver(l) < decver(r)
+}
+
+function decver (vs)
+{
+    pcnt = gsub(/[.]/, ".", vs)
+    if (pcnt < 2) return vs
+
+    len = split(vs, vc, ".")
+    dec = vc[1]
+    for (i=2; i<=len; i++) dec += (10 ^ (-i * 3)) * vc[i]
+    return dec
+}
+
+'
diff --git a/metas/perl.d/perl-dist b/metas/perl.d/perl-dist
new file mode 100755
index 0000000..3259fd8
--- /dev/null
+++ b/metas/perl.d/perl-dist
@@ -0,0 +1,584 @@
+#!/usr/bin/env perl
+
+use warnings 'FATAL' => 'all';
+use strict;
+
+my $PROG = 'perl-dist';
+
+package Convert;
+
+use Module::CoreList;
+use LWP::UserAgent qw();
+use YAML::XS qw();
+use version qw();
+
+# Match unpredictible package names .
+my %OVERRIDE =
+	('libwww-perl' => 'perl-libwww',
+	'aceperl' => 'perl-ace',
+	'mod_perl' => 'mod_perl',
+	'glade-perl-two' => 'perl-glade-two',
+	'Gnome2-GConf' => 'gconf-perl',
+	'Gtk2-GladeXML' => 'glade-perl',
+	'Glib' => 'glib-perl',
+	'Gnome2' => 'gnome-perl',
+	'Gnome2-VFS' => 'gnome-vfs-perl',
+	'Gnome2-Canvas' => 'gnomecanvas-perl',
+	'Gnome2-GConf' => 'gconf-perl',
+	'Gtk2' => 'gtk2-perl',
+	'Cairo' => 'cairo-perl',
+	'Pango' => 'pango-perl',
+	'Perl-Critic' => 'perl-critic',
+	'Perl-Tidy' => 'perl-tidy',
+	'App-Ack' => 'ack',
+	'TermReadKey' => 'perl-term-readkey');
+
+sub dist2pkg
+{
+	my ($name, $ver) = @_;
+	return dist_pkgname($name), dist_pkgver($ver);
+}
+
+# Copied from CPANPLUS::Dist::Arch
+sub dist_pkgname
+{
+	my ($distname) = @_;
+
+	return $OVERRIDE{$distname} if(exists($OVERRIDE{$distname}));
+
+	# Package names should be lowercase and consist of alphanumeric
+	# characters only (and hyphens!)...
+	$distname = lc($distname);
+	$distname =~ tr/_+/--/;
+	$distname =~ tr/-a-z0-9//cd; # Delete all other chars
+	$distname =~ tr/-/-/s;
+
+	# Delete leading or trailing hyphens...
+	$distname =~ s/\A-//;
+	$distname =~ s/-\z//;
+
+	die qq{Dist name '$distname' completely violates packaging standards}
+		if(length($distname) == 0);
+
+	# Don't prefix the package with perl- if it IS perl...
+	$distname = "perl-$distname" unless($distname eq 'perl');
+
+	return $distname;
+}
+
+sub dist_pkgver
+{
+	my ($version) = @_;
+
+	# Remove developer versions because pacman has no special logic
+	# to handle comparing them to regular versions such as perl uses.
+	$version =~ s/_[^_]+\z//;
+
+	# Package versions should be numbers and decimal points only...
+	$version =~ tr/-_/../;
+	$version =~ tr/0-9.//cd;
+
+	$version =~ tr/././s;
+	$version =~ s/^[.]|[.]$//g;
+
+	return $version;
+}
+
+#---HELPER FUNCTION---
+# Decide if the dist. is named after the module.
+sub _ismainmod
+{
+	my ($mod_name, $dist_name) = @_;
+
+	$mod_name =~ tr/:/-/s;
+	return lc($mod_name) eq lc($dist_name);
+}
+
+#---HELPER FUNCTION---
+# Merges the right-hand deps into the left-hand deps.
+sub _merge
+{
+	my ($left_deps, $right_deps) = @_;
+
+	MERGE_LOOP:
+	while(my ($pkg, $ver) = each(%$right_deps)) {
+		if($left_deps->{$pkg}) {
+			my $leftver = version->parse($left_deps->{$pkg});
+			my $rightver = version->parse($ver);
+			next MERGE_LOOP if $leftver > $rightver;
+		}
+		$left_deps->{$pkg} = $ver;
+	}
+
+	return;
+}
+
+#---HELPER FUNCTION---
+# Merge duplicate deps into $left always storing the greatest version there.
+sub _mergedups
+{
+	my ($left, $right) = @_;
+
+	for my $name (keys %$left) {
+		my $rver = delete($right->{$name}) or next;
+		my $lver = $left->{$name};
+		my $lvo = ($lver ? version->parse($lver) : 0);
+		my $rvo = ($rver ? version->parse($rver) : 0);
+		$left->{$name} = ($lvo > $rvo ? $lvo : $rvo);
+	}
+
+	return;
+}
+
+sub _filterdeps(&$)
+{
+	my ($fsub, $deps) = @_;
+	my %fed;
+
+	my @pkgs = keys(%$deps);
+	for my $dname (grep { $fsub->() } @pkgs){
+		my $dver = delete($deps->{$dname});
+		$fed{$dname} = $dver if(defined $dver);
+	}
+
+	return \%fed;
+}
+
+#---HELPER FUNCTION---
+sub _yankcheckers
+{
+	_filterdeps { /^perl-pod-coverage$|^perl-test-/ } $_[0]
+}
+
+#---HELPER FUNCTION---
+# Converts a decimal perl version (like $]) into the dotted decimal
+# form that the official ArchLinux perl package uses.
+sub _perldepver
+{
+	my ($perlver) = @_;
+
+	# Fix perl-style vstrings which have a leading "v".
+	return $perlver if($perlver =~ s/\Av//);
+	return $perlver unless($perlver =~ /\A(\d+)[.](\d{3})(\d{1,3})\z/);
+
+	# Re-apply the missing trailing zeroes.
+	my $patch = $3;
+	$patch .= q{0} x (3 - length($patch));
+	return sprintf('%d.%d.%d', $1, $2, $patch);
+}
+
+#---PUBLIC FUNCNTION---
+# Translates CPAN module dependencies into ArchLinux package dependencies.
+sub _reqs2deps
+{
+	my ($prereqs) = @_;
+	my (@mods, %pkgdeps);
+
+	# Filter out deps on 'perl' and any core modules that we can.
+	while(my ($name, $ver) = each(%$prereqs)) {
+		my $cver = $Module::CoreList::version{$]}{$name};
+		if($name eq 'perl') {
+			$pkgdeps{'perl'} = _perldepver($ver);
+		}elsif($cver && !$ver
+			|| version->parse($ver) > version->parse($cver)){
+			# Only add deps for core modules if we need a higher
+			# version than what is in the core for our perl interpreter.
+			;
+		}else{
+			push @mods, $name;
+		}
+	}
+
+	my %dists = _distsofmods(@mods);
+	while(my ($mod, $dist) = each %dists) {
+		my $pkgname = dist_pkgname($dist);
+		my $ver = $prereqs->{$mod};
+
+		# If the module is not named after the distribution, ignore its
+		# version which might not match the distribution.
+		undef $ver unless(_ismainmod($mod, $dist));
+
+		# If two module prereqs are in the same CPAN distribution then
+		# the version required for the main module will override.
+		# (because versions specified for other modules in the dist
+		# are 0)
+		$pkgdeps{$pkgname} ||= ($ver ? dist_pkgver($ver) : 0);
+	}
+
+	return \%pkgdeps;
+}
+
+sub prereqs
+{
+	my ($pkgname, $prereqs) = @_;
+
+	# maps perl names for different dependencies to ArchLinux's names
+	my %namemap = ('configure' => 'makedepends',
+				   'build' => 'makedepends',
+				   'test' => 'checkdepends',
+				   'runtime' => 'depends');
+
+	my %pkgdeps;
+	while (my ($perl, $arch) = each(%namemap)) {
+		my $reqs = $prereqs->{$perl}{'requires'};
+		my $deps; $deps = _reqs2deps($reqs) if($reqs);
+
+		next unless(keys(%$deps));
+		if($pkgdeps{$arch}) { _merge($pkgdeps{$arch}, $deps); }
+		else { $pkgdeps{$arch} = $deps; }
+	}
+
+	# ArchLinux now has a separate array for dependencies that we only
+	# need for checking (aka "testing"). Older perl METAs do not
+	# have this separated. Force any test modules to be checkdepends.
+	if(!$pkgdeps{'checkdepends'} && $pkgname !~ /\Aperl-test-/) {
+		my $checkdeps = {};
+		_merge($checkdeps, _yankcheckers($pkgdeps{$_})) for(qw/makedepends depends/);
+		$pkgdeps{'checkdepends'} = $checkdeps;
+	}
+
+	# We at least require perl, if nothing else.
+	unless(grep { scalar(keys(%$_)) > 0 } values(%pkgdeps)) {
+		$pkgdeps{'depends'}{'perl'} = 0;
+	}
+
+	_mergedups(@pkgdeps{'makedepends', 'checkdepends'});
+	_mergedups(@pkgdeps{'depends', 'makedepends'});
+
+	# Convert all deps into arrays of strings.
+	for my $deptype (keys(%pkgdeps)) {
+		$pkgdeps{$deptype} = _stringify($pkgdeps{$deptype});
+	}
+
+	return \%pkgdeps;
+}
+
+#---HELPER FUNCTION---
+sub _stringify
+{
+	my ($deps) = @_;
+
+	my @depstrs;
+	for my $pkg (sort(keys(%$deps))) {
+		my $ver = $deps->{$pkg};
+		my $str = ($ver eq '0' ? $pkg : "$pkg>=$ver");
+		push(@depstrs, $str);
+	}
+
+	return \@depstrs;
+}
+
+sub _distsofmods
+{
+	my (@mods) = @_;
+
+	return () if(@mods == 0);
+	@mods = _nocore(@mods);
+
+	my $var = _vardir();
+	open(my $fh, '<', "$var/cpanmods")
+		or die "$PROG: failed to open $var/cpanmods: $!";
+
+	my %mods = map { ($_ => 1) } @mods;
+	my %dists;
+	local $/ = '';
+
+	RECLOOP:
+	while(my $rec = <$fh>) {
+		last RECLOOP unless(keys %mods > 0);
+
+		my($dist, @mvs) = split(/\n/, $rec);
+		MODLOOP:
+		for(@mvs){
+			my($m) = split;
+			my $fnd = delete($mods{$m}) or next;
+			$dists{$m} = $dist;
+		}
+	}
+
+	my @lost = keys %mods;
+	if(@lost){
+		for my $m (@lost){
+			print STDERR "$PROG: failed to find module $m\n";
+		}
+		exit 1;
+	}
+
+	return %dists;
+}
+
+sub _nocore
+{
+	my (@mods) = @_;
+
+	my $path = _vardir() . '/coremods';
+	open(my $if, '<', $path) or die "$PROG: open $path: $!";
+
+	my %mods = map { ($_ => 1) } @mods;
+	while(<$if>){
+		my ($m) = split;
+		delete $mods{$m};
+	}
+
+	close($if);
+	return keys %mods;
+}
+
+sub _vardir
+{
+	return $ENV{'PKGVAR'}
+		or die "$PROG: PKGVAR env variable is unset\n";
+}
+
+#-----------------------------------------------------------------------------
+
+package main;
+
+use File::Basename qw(basename dirname);
+use File::Spec::Functions qw(catfile catdir);
+use File::Find qw(find);
+
+use JSON::XS qw(decode_json); # for META.json
+use YAML::XS (); # for META.yml
+use Pod::Select (); # search POD for description
+
+use Digest::MD5 (); # for md5sums & sha512sums
+use Digest::SHA ();
+
+sub main
+{
+	my $distpath = shift() or die "Usage: $PROG [path to cpan dist file]\n";
+	my $dir = dirname($distpath);
+	my $file = basename($distpath);
+	my $info = distinfo($file);
+
+	chsrcdir(catdir($dir, 'src'), $file);
+	$dir = extractdist($file);
+
+	my $meta = loadmeta($dir);
+	my $desc = $meta->{'abstract'};
+	if(!$desc || $desc eq '~' || $desc eq 'unknown') {
+		$meta->{'abstract'} = distdesc($dir, $info->{'mod'});
+	}
+
+	my ($name, $ver) = Convert::dist2pkg(@{$info}{'name', 'ver'});
+	my $deps = Convert::prereqs($name, $meta->{'prereqs'});
+
+	my %pbvars =
+		('pkgver'  => $ver,
+		 'pkgdesc' => $meta->{'abstract'},
+		 'arch' => (xsdist($dir) ? ['i686', 'x86_64'] : 'any'),
+		 'md5sums' => md5sums($file),
+		 'sha512sums' => sha512sums($file),
+		 'distdir' => $dir,
+		 %$deps,
+		 );
+
+	# Since this is a perl distribution, use the perl-pkg template.
+	printf("template\nperl-pkg %s\n\n", (-f "$dir/Build.PL" ? "MB" : "MM"));
+	print("options\n!emptydirs\n\n");
+
+	printmeta(\%pbvars);
+	return 0;
+}
+
+# Create the src/ directory and tarball symlink. Then chdir into it.
+
+sub chsrcdir
+{
+	my ($srcdir, $distfile) = @_;
+
+	if (-e $srcdir) {
+		system("rm", "-fr", $srcdir) == 0 or die "failed to rm $srcdir\n";
+	}
+	mkdir $srcdir or die "mkdir $srcdir: $!";
+	chdir($srcdir) or die "chdir $srcdir: $!";
+	unless(-f $distfile) {
+		symlink(catfile('..', $distfile), $distfile) or die "symlink $distfile: $!";
+	}
+
+	return $srcdir;
+}
+
+sub distinfo
+{
+	my ($distfile) = @_;
+
+	my @c = split(/-/, $distfile);
+	my $ver = pop(@c);
+	my $name = join(q{-}, @c);
+	my $mod = $name;
+	$mod =~ s/-/::/g;
+	return { 'name' => $name, 'ver' => $ver, 'mod' => $mod };
+}
+
+sub extractdist
+{
+	my ($file) = @_;
+
+	system("bsdtar -xf $file");
+	die "$PROG: bsdtar failed to extract $file\n" unless($? == 0);
+
+	opendir(my $srcdir, '.') or die "opendir: $!";
+	my @dirs = grep { -d $_ && !/\A[.]/ } readdir($srcdir);
+	closedir($srcdir);
+
+	die("$PROG: many dirs (@dirs) inside the tarball $file\n")
+		if(@dirs > 1);
+	die("$PROG: no dirs found in tarball $file\n") if(@dirs == 0);
+	return $dirs[0];
+}
+
+sub printmeta
+{
+	my ($pbvars) = @_;
+	while(my ($name, $val) = each(%$pbvars)) {
+		if(!defined($val) || $val eq q{}) {
+			warn("$PROG: warning: $name is undefined\n");
+			$val = q{};
+		}
+		print($name, "\n");
+		print("$_\n") for (ref $val ? @$val : $val);
+		print("\n");
+	}
+
+	# TODO: autodetect license type
+	printf("license\n%s\n\n", join("\n", qw/PerlArtistic GPL/));
+}
+
+sub loadmeta
+{
+	my ($distdir) = @_;
+
+	for my $metaext (qw/json yml/) {
+		my $path = "$distdir/META.$metaext";
+		next unless -f $path;
+
+		open(my $metafh, '<', $path) or die "open: $!";
+		my $meta = do { local $/; <$metafh> };
+		close($metafh);
+
+		$meta = ($metaext eq 'json' ? decode_json($meta) :
+			$metaext eq 'yml' ? YAML::XS::Load($meta) :
+			die "internal error: unknown \$metaext: $metaext");
+
+		upgrademeta($meta);
+		return $meta;
+	}
+
+	return undef;
+}
+
+sub upgrademeta
+{
+	my ($meta) = @_;
+
+	return if(exists($meta->{'prereqs'}));
+
+	my $prereqs;
+	$prereqs->{'configure'}{'requires'} = delete($meta->{'configure_requires'});
+	$prereqs->{'build'}{'requires'} = delete($meta->{'build_requires'});
+	$prereqs->{'runtime'}{'requires'} = delete($meta->{'requires'});
+
+	$meta->{'prereqs'} = $prereqs;
+	return;
+}
+
+sub xsdist
+{
+	my ($dir) = @_;
+	my $isxs;
+	find({ 'wanted' => sub { $isxs = 1 if(/[.]xs$/) }, 'no_chdir' => 1 }, $dir);
+	return $isxs;
+}
+
+#-----------------------------------------------------------------------------
+
+sub distdesc
+{
+	my ($dir, $modname) = @_;
+	return _poddesc($dir, $modname) || _readmedesc($dir, $modname);
+}
+
+sub _poddesc
+{
+	my ($dir, $modname) = @_;
+
+	my $podselect = Pod::Select->new;
+	$podselect->select('NAME');
+
+	my $modpath = $modname; $modpath =~ s{::}{/}g;
+	my $moddir = dirname($modpath);
+	my $modfile = basename($modpath);
+
+	# First check under lib/ for a "properly" pathed module, with
+	# nested directories. Then search desperately for a .pm file that
+	# matches the module's last name component.
+
+	my @possible = glob("$dir/{lib/,}{$moddir/,}$modfile.{pod,pm}");
+
+	PODSEARCH:
+	for my $podpath (@possible) {
+		next PODSEARCH unless(-f $podpath);
+
+		# Read the NAME section of the POD into a scalar.
+		my $namesect = q{};
+		open(my $podfile, '<', $podpath) or next PODSEARCH;
+		open(my $podout, '>', \$namesect) or die "open: $!";
+
+		$podselect->parse_from_filehandle($podfile, $podout);
+
+		close($podfile);
+		close($podout) or die "close: $!";
+
+		next PODSEARCH unless($namesect);
+
+		# Remove formatting codes.
+		$namesect =~ s{ [IBCLEFSXZ] <(.*?)> }{$1}gxms;
+		$namesect =~ s{ [IBCLEFSXZ] <<(.*?)>> }{$1}gxms;
+
+		# The short desc is on a line beginning with 'Module::Name - '
+		return $1 if($namesect =~ / ^ \s* $modname [ -]+ ([^\n]+) /xms);
+	}
+
+	return undef;
+}
+
+#---HELPER FUNCTION---
+sub _readmedesc
+{
+	my ($dir, $modname) = @_;
+
+	my $path = catfile($dir, 'README');
+	return undef unless(-f $path);
+	open(my $fh, '<', $path) or die "open: $!";
+
+	while (<$fh>) {
+		chomp;
+		next unless((/\ANAME/ ... /\A[A-Z]+/)
+			&& / \A \s* ${modname} [\s\-]+ (.+) \z /x);
+		return $1;
+	}
+
+	close $fh;
+	return undef;
+}
+
+#-----------------------------------------------------------------------------
+
+sub md5sums
+{
+	return [ map {
+		open(my $fh, '<', $_) or die "open: $!";
+		my $md5 = Digest::MD5->new()->addfile($fh)->hexdigest;
+	} @_ ]
+}
+
+sub sha512sums
+{
+	return [ map {
+		my $sha = Digest::SHA->new(512)->addfile($_)->hexdigest;
+	} @_ ]
+}
+
+exit main(@ARGV);
diff --git a/metas/perl.d/scrapecore b/metas/perl.d/scrapecore
new file mode 100755
index 0000000..2e1aba3
--- /dev/null
+++ b/metas/perl.d/scrapecore
@@ -0,0 +1,241 @@
+#!/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 $var = $ENV{'PKGVAR'} || "$ENV{'HOME'}/var";
+	my $path = "$var/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));
+
+## Embedded modules without any files...
+push @mods, [qw/ Config 1/];
+
+@mods = coreonly(@mods);
+for my $mv (@mods){ print "@$mv\n"; }