From 59f20f067492dec2bdc38697f12e1a64ec72f80b Mon Sep 17 00:00:00 2001
From: Justin Davis <jrcd83@gmail.com>
Date: Sat, 2 Jun 2012 12:49:40 -0400
Subject: A general cleanup of the perlcore script.

---
 misc/perlcore | 174 ++++++++++++++++++++--------------------------------------
 1 file changed, 58 insertions(+), 116 deletions(-)

diff --git a/misc/perlcore b/misc/perlcore
index 6eb25ae..0f1a2a2 100755
--- a/misc/perlcore
+++ b/misc/perlcore
@@ -5,28 +5,6 @@ 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;
@@ -34,83 +12,17 @@ package CoreDist;
 use File::Basename qw(basename);
 use File::Find qw();
 *findfile = *File::Find::find;
+*findver = *main::findver;
 
-sub modname
+sub pathmod
 {
-	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;
+	my($p) = @_;
+	for ($p){
+		s{^lib/}{};
+		s{[.]pm$}{};
+		s{/}{::}g;
 	}
-
-	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);
+	return $p;
 }
 
 # scans a directory full of nicely separated dist. directories.
@@ -122,20 +34,19 @@ sub scan_distroot
 	closedir $cpand;
 
 	my @found;
-	for my $ddir (map { "$distroot/$_/" } @dists){
-		$ddir .= 'lib/' if(-d "$ddir/lib");
+	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//;
-			s{^lib/}{};
-			s{[.]pm$}{};
-			s{/}{::}g;
-			my $m = $_;
+			s{^\Q$ddir\E/}{};
+			my $m = pathmod($_);
 	
-			my $v = Common::evalver($p, $m);
+			my $v = findver($p, $m);
 			if($v){
 				push @found, [ $m, $v ];
 			}else{
@@ -162,6 +73,7 @@ use File::Find qw();
 use File::stat;
 
 *findfile = *File::Find::find;
+*findver = *main::findver;
 
 sub findmods
 {
@@ -201,7 +113,7 @@ sub findmods
 		$mod =~ s{\A$libdir}{};
 		$mod =~ s{/}{::}g;
 
-		my $ver = Common::evalver($path, $mod);
+		my $ver = findver($path, $mod);
 		if($ver){
 			push @mods, [ $mod, $ver ];
 		}else{
@@ -215,7 +127,29 @@ sub findmods
 
 package main;
 
-sub _delmods
+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(@_){
@@ -225,27 +159,35 @@ sub _delmods
 	return;
 }
 
-sub printmods
+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($dist, @dms) = split /\n/;
-			_delmods(\%coreonly, @dms);
-		}
-		close $if;
+	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{*} : ());
+		printf "%s\n", join q{ }, $m, $v, ($coreonly->{$m} ? q{*} : ());
 	}
+
+	return;
 }
 
 sub main
-- 
cgit v1.2.3-24-g4f1b