290 lines
7.4 KiB
Perl
Executable file
290 lines
7.4 KiB
Perl
Executable file
#!/usr/bin/env perl
|
|
##
|
|
# Script for printing out a provides list of every CPAN distribution
|
|
# that is bundled with perl. You can run it before building perl
|
|
# or you can run it after building perl. Required modules are in core
|
|
# for perl 5.13 and above. It might be nice if this didn't require
|
|
# HTTP::Tiny and maybe just used wget or curl.
|
|
#
|
|
# This script uses HTTP::Tiny to query Tatsuhiko Miyagawa's webapp at
|
|
# cpanmetadb.plackperl.org to cross-reference module files to their
|
|
# providing CPAN distribution. Thank you Miyagawa!
|
|
#
|
|
# - Justin "juster" Davis <jrcd83@gmail.com>
|
|
#
|
|
# Based on the Archlinux version and modified for xbps.
|
|
|
|
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 (my $ln = <$fh>) {
|
|
next unless $ln =~ /\s*$m\s*=\s*.+/;
|
|
chomp $ln;
|
|
my $ver = do { no strict; eval $ln };
|
|
return $ver unless $@;
|
|
die qq{$path:$. bad version string in "$ln"\n};
|
|
}
|
|
|
|
close $fh;
|
|
return undef;
|
|
}
|
|
|
|
|
|
#-----------------------------------------------------------------------------
|
|
|
|
package Dists;
|
|
|
|
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 = $dist;
|
|
$mod =~ s/-/::/g;
|
|
my $ver = Common::evalver($path, $mod);
|
|
unless ($ver) {
|
|
warn "failed to find version in module file for $dist\n";
|
|
return undef;
|
|
}
|
|
|
|
return $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;
|
|
|
|
open my $fh, '<', $path or die "open: $!";
|
|
while (<$fh>) {
|
|
return $1 if /\A\s*(?:$dist[ \t]*)?([0-9._]+)/;
|
|
return $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
|
|
|
|
return Common::evalver($path);
|
|
}
|
|
|
|
# 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 $ver = (module_ver($dist, $distdir)
|
|
|| changelog_ver($dist, $distdir)
|
|
|| verfile_ver($dist, $distdir));
|
|
|
|
if ($ver) { push @found, [ $dist, $ver ]; }
|
|
else { warn "failed to find version for $dist\n"; }
|
|
}
|
|
return @found;
|
|
}
|
|
|
|
sub find
|
|
{
|
|
my ($srcdir) = @_;
|
|
return map { scan_distroot($_) } glob "$srcdir/{cpan,dist}";
|
|
}
|
|
|
|
#-----------------------------------------------------------------------------
|
|
|
|
package Modules;
|
|
|
|
use HTTP::Tiny qw();
|
|
use File::Find qw();
|
|
use File::stat;
|
|
|
|
*findfile = *File::Find::find;
|
|
|
|
sub cpan_provider
|
|
{
|
|
my ($module) = @_;
|
|
my $url = "http://cpanmetadb.plackperl.org/v1.0/package/$module";
|
|
my $http = HTTP::Tiny->new;
|
|
my $resp = $http->get($url);
|
|
return undef unless $resp->{'success'};
|
|
|
|
my ($cpanpath) = $resp->{'content'} =~ /^distfile: (.*)$/m
|
|
or return undef;
|
|
|
|
my $dist = $cpanpath;
|
|
$dist =~ s{\A.+/}{}; # remove author directory
|
|
$dist =~ s{-[^-]+\z}{}; # remove version and extension
|
|
return ($dist eq 'perl' ? undef : $dist);
|
|
}
|
|
|
|
sub find
|
|
{
|
|
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/;
|
|
return if m{\Q$libdir\E[^/]+/t/}; # ignore testing modules
|
|
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 ];
|
|
}
|
|
|
|
# Convert modules names to the dist names who provide them.
|
|
my %seen;
|
|
my @dists;
|
|
for my $modref (@mods) {
|
|
my ($mod, $ver) = @$modref;
|
|
my $dist = cpan_provider($mod) or next; # filter out core modules
|
|
next if $seen{$dist}++; # avoid duplicate dists
|
|
push @dists, [ $dist, $ver ];
|
|
}
|
|
return @dists;
|
|
}
|
|
|
|
#-----------------------------------------------------------------------------
|
|
|
|
package Dist2Pkg;
|
|
|
|
sub name
|
|
{
|
|
my ($name) = @_;
|
|
my $orig = $name;
|
|
|
|
# Delete leading or trailing hyphens...
|
|
$name =~ s/\A-|-\z//g;
|
|
|
|
die qq{Dist. name '$orig' completely violates packaging standards}
|
|
unless $name;
|
|
|
|
return "perl-$name";
|
|
}
|
|
|
|
sub version
|
|
{
|
|
my ($version) = @_;
|
|
|
|
# Package versions should be numbers and decimal points only...
|
|
$version =~ tr/-/./;
|
|
$version =~ tr/_0-9.-//cd;
|
|
|
|
$version =~ tr/././s; # only one period at a time
|
|
$version =~ s/\A[.]|[.]\z//g; # shouldn't start or stop with a period
|
|
|
|
return $version;
|
|
}
|
|
|
|
#-----------------------------------------------------------------------------
|
|
|
|
package main;
|
|
|
|
my %CPANNAME = ('List-Util' => 'Scalar-List-Utils',
|
|
'Text-Tabs' => 'Text-Tabs+Wrap',
|
|
'Cwd' => 'PathTools');
|
|
|
|
my $perldir = shift or die "Usage: $0 [path to perl source directory]\n";
|
|
die "$perldir is not a valid directory." unless -d $perldir;
|
|
|
|
my @dists = (Dists::find($perldir), Modules::find($perldir));
|
|
for my $dist (@dists) {
|
|
my $name = $dist->[0];
|
|
$dist->[0] = $CPANNAME{$name} if exists $CPANNAME{$name};
|
|
}
|
|
|
|
my @pkgs = map {
|
|
my ($name, $ver) = @$_;
|
|
$name = Dist2Pkg::name($name);
|
|
$ver = Dist2Pkg::version($ver);
|
|
[ $name, $ver ];
|
|
} @dists;
|
|
|
|
@pkgs = sort { $a->[0] cmp $b->[0] } @pkgs;
|
|
|
|
for my $pkg (@pkgs) {
|
|
my ($name, $ver) = @$pkg;
|
|
print "$name-$ver\_1\n";
|
|
}
|