Fix perlcore to work properly. Mark core-only modules.

Find every module, not just the main module in the distribution.
This acted like provides.pl in perlpkgscripts. Now I remember why
I used Module::CoreList instead of going through this.

Updates the perlcore.mods-* files under misc/ as well. Fix perl-dist
to parse the extra * properly.

1 files changed, 65 insertions, 45 deletions

diff --git a/misc/perlcore b/misc/perlcore
index b9c1b80..6eb25ae 100755
--- a/misc/perlcore
+++ b/misc/perlcore
@@ -30,7 +30,10 @@ sub evalver
 # ----------------------------------------
 
 package CoreDist;
+
 use File::Basename qw(basename);
+use File::Find qw();
+*findfile = *File::Find::find;
 
 sub modname
 {
@@ -115,28 +118,40 @@ sub scan_distroot
 {
 	my ($distroot) = @_;
 	opendir my $cpand, "$distroot" or die("failed to open $distroot");
-	my @dists = grep { !/^\./ && -d "$distroot/$_" } readdir $cpand;
+	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";
-		}
+	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,ext}";
+	return map { scan_distroot($_) } glob "$srcdir/{cpan,dist}";
 }
 
 # ----------------------------------------
@@ -200,51 +215,56 @@ sub findmods
 
 package main;
 
-sub _delmatch
+sub _delmods
 {
-	my($mvs, $findus) = @_;
-	for(@$mvs){
+	my $coreonly = shift;
+	for(@_){
 		my($m) = split;
-		delete $findus->{$m};
+		delete $coreonly->{$m};
 	}
 	return;
 }
 
-sub coreonly
+sub printmods
 {
-	my %mods = map { @$_ } @_;
-	my $var = $ENV{'PKGVAR'} || "$ENV{'HOME'}/.genpkg/var";
-	my $path = "$var/cpanmods";
-	unless(-f $path){
-		die "$0: $path is missing. Generate it with fetchcpan.\n";
-	}
-	open my $if, '<', $path or die "open $path failed: $!";
-
-	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);
+	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;
 	}
 
-	close $if;
-	my @core;
-	for my $k (keys %mods){
-		push(@core, [ $k, $mods{$k} ]);
+	# 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 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);
+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));
+	my @mods = (CoreDist::findmods($perldir), CoreLib::findmods($perldir));
 
-## Embedded modules without any files...
-push @mods, [ 'Config' => 1 ];
+	## Embedded modules without any files...
+	push @mods, [ 'Config' => 1 ];
+
+	@mods = sort { $a->[0] cmp $b->[0] } @mods;
+	printmods(\@mods, $mpath);
+
+	return 0;
+}
 
-print "@$_\n" for(coreonly(@mods));
+exit main(@ARGV);