diff options
Diffstat (limited to 'testing/perl/provides.pl')
| -rw-r--r-- | testing/perl/provides.pl | 299 |
1 files changed, 0 insertions, 299 deletions
diff --git a/testing/perl/provides.pl b/testing/perl/provides.pl deleted file mode 100644 index d2cdc762e..000000000 --- a/testing/perl/provides.pl +++ /dev/null @@ -1,299 +0,0 @@ -# provides.pl -## -# 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> - -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; - - # Package names should be lowercase and consist of alphanumeric - # characters only (and hyphens!)... - $name =~ tr/A-Z/a-z/; - $name =~ tr/_+/-/; # _ and +'s converted to - (ie Tabbed-Text+Wrap) - $name =~ tr/-a-z0-9+//cd; # Delete all other chars. - $name =~ tr/-/-/s; - - # 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; - - # Remove developer versions because pacman has no special logic - # to compare them to regular versions like perl does. - $version =~ s/_[^_]+\z//; - - $version =~ tr/_//d; # delete other underscores - $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\n"; -} |