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($@);
		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);
		if($ver){
			push @mods, [ $mod, $ver ];
		}else{
			warn "failed to find version in module file $path\n";
		}
	}
	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'}/.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);
	}

	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, [ 'Config' => 1 ];

print "@$_\n" for(coreonly(@mods));