diff options
Diffstat (limited to 'metas')
| -rwxr-xr-x | metas/perl | 106 | ||||
| -rwxr-xr-x | metas/perl.d/fetchcpan | 60 | ||||
| -rwxr-xr-x | metas/perl.d/perl-dist | 584 | ||||
| -rwxr-xr-x | metas/perl.d/scrapecore | 241 |
4 files changed, 991 insertions, 0 deletions
diff --git a/metas/perl b/metas/perl new file mode 100755 index 0000000..4b61175 --- /dev/null +++ b/metas/perl @@ -0,0 +1,106 @@ +#!/usr/bin/env perl + +use warnings 'FATAL' => 'all'; +use strict; + +use File::Fetch; +use IO::Handle; # for autoflush +use Cwd; + +my $PROG = 'metas/perl'; +my %BADNAMES = ('perl-libwww' => 'libwww-perl'); + +sub err +{ + print STDERR "$PROG: ", @_, "\n"; + exit 1; +} + +sub matchdist +{ + my($dist) = @_; + + # Refresh our local list of distributions if needed. + my $var = $ENV{'PKGVAR'} + or err('PKGVAR env variable is unset'); + + if(!-f "$var/cpandists" || -M "$var/cpandists" > 1) { + print STDERR "$PROG: Refreshing local CPAN data... "; + my $cwd = getcwd(); + chdir $var or die "chdir: $!"; + system 'fetchcpan'; + die "FAILED\n" unless($? == 0); + print STDERR "OK\n"; + chdir $cwd or die "chdir: $!"; + } + + open(DISTS, '<', "$var/cpandists") or err("open: $!"); + while(<DISTS>) { + my @f = split; + my $d = lc $f[0]; $d =~ tr/-_/--/s; + next unless($d eq lc($dist)); + close(DISTS); + return ($f[0], $f[2]); + } + close(DISTS); + return (); +} + +sub fetchdist +{ + my($cpath) = @_; + my $file = $cpath; $file =~ s{^.*/}{}; + if(-f $file) { + print STDERR "$file already downloaded.\n"; + return; + } + + my $mirror = $ENV{'CPANMIRROR'} || 'ftp://cpan.pair.com'; + my $url = "${mirror}/authors/id/${cpath}"; + + print STDERR "Downloading $file... "; + my $ff = File::Fetch->new('uri' => $url); + die "FAILED\n" unless($ff->fetch()); + print STDERR "OK\n"; +} + +sub main +{ + my $dist = shift or die "usage: $PROG [package name]\n"; + + my $guess; + if($BADNAMES{$dist}){ + $dist = $BADNAMES{$dist}; + }elsif($dist =~ s/^perl-// == 0){ + $guess = 1; + $dist = "app-$dist"; + } + + STDERR->autoflush(1); + my ($realname, $cpath) = matchdist($dist); + unless($realname){ + if($guess){ + return 2 + }else{ + ## Return a hard error to makepkgmeta if perl- package. + err(qq{failed to find perl dist similar to '$dist'}); + return 1 + } + } + fetchdist($cpath); + + print <<"END_META"; +url +https://metacpan.org/release/$realname + +source +http://search.cpan.org/CPAN/authors/id/$cpath + +END_META + + my $file = $cpath; $file =~ s{.*/}{}; + system 'perl-dist' => $file; + return $?; +} + +exit main(@ARGV); diff --git a/metas/perl.d/fetchcpan b/metas/perl.d/fetchcpan new file mode 100755 index 0000000..076599b --- /dev/null +++ b/metas/perl.d/fetchcpan @@ -0,0 +1,60 @@ +#!/bin/sh + +mirror=${CPANMIRROR:-ftp://cpan.pair.com} +path=/modules/02packages.details.txt.gz + +curl --silent "$mirror$path" | gzip -dc | awk ' +NR < 10 { next } +{ + file = a[split($3, a, "/")] + + if (!match(file, /[-_][vV]?[0-9]+/)) { + #print "error: failed to grok " $3 | "cat 1>&2" + next + } + ver = substr(file, RSTART+1) + dist = substr(file, 1, RSTART-1) + + sub(/[.]tar[.].*$|[.]zip$/, "", ver) + sub(/^[vV]/, "", ver) + sub(/[.]pm$/, "", dist) + + if(dist == "perl") next + + mods[dist,ver] = mods[dist,ver] $1 " " $2 "\n" + if (lessthan(dists[dist], ver)) { + dists[dist] = ver + paths[dist] = $3 + } +} + +END { + for (dist in dists) { + ver = dists[dist] + print dist, ver, paths[dist] | "sort >cpandists" + } + close("sort >cpandists") + + # Prints modules out in sorted order, too! + while(getline<"cpandists" > 0) { + print $1 "\n" mods[$1,$2] >"cpanmods" + } +} + +function lessthan (l, r) +{ + return decver(l) < decver(r) +} + +function decver (vs) +{ + pcnt = gsub(/[.]/, ".", vs) + if (pcnt < 2) return vs + + len = split(vs, vc, ".") + dec = vc[1] + for (i=2; i<=len; i++) dec += (10 ^ (-i * 3)) * vc[i] + return dec +} + +' diff --git a/metas/perl.d/perl-dist b/metas/perl.d/perl-dist new file mode 100755 index 0000000..3259fd8 --- /dev/null +++ b/metas/perl.d/perl-dist @@ -0,0 +1,584 @@ +#!/usr/bin/env perl + +use warnings 'FATAL' => 'all'; +use strict; + +my $PROG = 'perl-dist'; + +package Convert; + +use Module::CoreList; +use LWP::UserAgent qw(); +use YAML::XS qw(); +use version qw(); + +# Match unpredictible package names . +my %OVERRIDE = + ('libwww-perl' => 'perl-libwww', + 'aceperl' => 'perl-ace', + 'mod_perl' => 'mod_perl', + 'glade-perl-two' => 'perl-glade-two', + 'Gnome2-GConf' => 'gconf-perl', + 'Gtk2-GladeXML' => 'glade-perl', + 'Glib' => 'glib-perl', + 'Gnome2' => 'gnome-perl', + 'Gnome2-VFS' => 'gnome-vfs-perl', + 'Gnome2-Canvas' => 'gnomecanvas-perl', + 'Gnome2-GConf' => 'gconf-perl', + 'Gtk2' => 'gtk2-perl', + 'Cairo' => 'cairo-perl', + 'Pango' => 'pango-perl', + 'Perl-Critic' => 'perl-critic', + 'Perl-Tidy' => 'perl-tidy', + 'App-Ack' => 'ack', + 'TermReadKey' => 'perl-term-readkey'); + +sub dist2pkg +{ + my ($name, $ver) = @_; + return dist_pkgname($name), dist_pkgver($ver); +} + +# Copied from CPANPLUS::Dist::Arch +sub dist_pkgname +{ + my ($distname) = @_; + + return $OVERRIDE{$distname} if(exists($OVERRIDE{$distname})); + + # Package names should be lowercase and consist of alphanumeric + # characters only (and hyphens!)... + $distname = lc($distname); + $distname =~ tr/_+/--/; + $distname =~ tr/-a-z0-9//cd; # Delete all other chars + $distname =~ tr/-/-/s; + + # Delete leading or trailing hyphens... + $distname =~ s/\A-//; + $distname =~ s/-\z//; + + die qq{Dist name '$distname' completely violates packaging standards} + if(length($distname) == 0); + + # Don't prefix the package with perl- if it IS perl... + $distname = "perl-$distname" unless($distname eq 'perl'); + + return $distname; +} + +sub dist_pkgver +{ + my ($version) = @_; + + # Remove developer versions because pacman has no special logic + # to handle comparing them to regular versions such as perl uses. + $version =~ s/_[^_]+\z//; + + # Package versions should be numbers and decimal points only... + $version =~ tr/-_/../; + $version =~ tr/0-9.//cd; + + $version =~ tr/././s; + $version =~ s/^[.]|[.]$//g; + + return $version; +} + +#---HELPER FUNCTION--- +# Decide if the dist. is named after the module. +sub _ismainmod +{ + my ($mod_name, $dist_name) = @_; + + $mod_name =~ tr/:/-/s; + return lc($mod_name) eq lc($dist_name); +} + +#---HELPER FUNCTION--- +# Merges the right-hand deps into the left-hand deps. +sub _merge +{ + my ($left_deps, $right_deps) = @_; + + MERGE_LOOP: + while(my ($pkg, $ver) = each(%$right_deps)) { + if($left_deps->{$pkg}) { + my $leftver = version->parse($left_deps->{$pkg}); + my $rightver = version->parse($ver); + next MERGE_LOOP if $leftver > $rightver; + } + $left_deps->{$pkg} = $ver; + } + + return; +} + +#---HELPER FUNCTION--- +# Merge duplicate deps into $left always storing the greatest version there. +sub _mergedups +{ + my ($left, $right) = @_; + + for my $name (keys %$left) { + my $rver = delete($right->{$name}) or next; + my $lver = $left->{$name}; + my $lvo = ($lver ? version->parse($lver) : 0); + my $rvo = ($rver ? version->parse($rver) : 0); + $left->{$name} = ($lvo > $rvo ? $lvo : $rvo); + } + + return; +} + +sub _filterdeps(&$) +{ + my ($fsub, $deps) = @_; + my %fed; + + my @pkgs = keys(%$deps); + for my $dname (grep { $fsub->() } @pkgs){ + my $dver = delete($deps->{$dname}); + $fed{$dname} = $dver if(defined $dver); + } + + return \%fed; +} + +#---HELPER FUNCTION--- +sub _yankcheckers +{ + _filterdeps { /^perl-pod-coverage$|^perl-test-/ } $_[0] +} + +#---HELPER FUNCTION--- +# Converts a decimal perl version (like $]) into the dotted decimal +# form that the official ArchLinux perl package uses. +sub _perldepver +{ + my ($perlver) = @_; + + # Fix perl-style vstrings which have a leading "v". + return $perlver if($perlver =~ s/\Av//); + return $perlver unless($perlver =~ /\A(\d+)[.](\d{3})(\d{1,3})\z/); + + # Re-apply the missing trailing zeroes. + my $patch = $3; + $patch .= q{0} x (3 - length($patch)); + return sprintf('%d.%d.%d', $1, $2, $patch); +} + +#---PUBLIC FUNCNTION--- +# Translates CPAN module dependencies into ArchLinux package dependencies. +sub _reqs2deps +{ + my ($prereqs) = @_; + my (@mods, %pkgdeps); + + # Filter out deps on 'perl' and any core modules that we can. + while(my ($name, $ver) = each(%$prereqs)) { + my $cver = $Module::CoreList::version{$]}{$name}; + if($name eq 'perl') { + $pkgdeps{'perl'} = _perldepver($ver); + }elsif($cver && !$ver + || version->parse($ver) > version->parse($cver)){ + # Only add deps for core modules if we need a higher + # version than what is in the core for our perl interpreter. + ; + }else{ + push @mods, $name; + } + } + + my %dists = _distsofmods(@mods); + while(my ($mod, $dist) = each %dists) { + my $pkgname = dist_pkgname($dist); + my $ver = $prereqs->{$mod}; + + # If the module is not named after the distribution, ignore its + # version which might not match the distribution. + undef $ver unless(_ismainmod($mod, $dist)); + + # If two module prereqs are in the same CPAN distribution then + # the version required for the main module will override. + # (because versions specified for other modules in the dist + # are 0) + $pkgdeps{$pkgname} ||= ($ver ? dist_pkgver($ver) : 0); + } + + return \%pkgdeps; +} + +sub prereqs +{ + my ($pkgname, $prereqs) = @_; + + # maps perl names for different dependencies to ArchLinux's names + my %namemap = ('configure' => 'makedepends', + 'build' => 'makedepends', + 'test' => 'checkdepends', + 'runtime' => 'depends'); + + my %pkgdeps; + while (my ($perl, $arch) = each(%namemap)) { + my $reqs = $prereqs->{$perl}{'requires'}; + my $deps; $deps = _reqs2deps($reqs) if($reqs); + + next unless(keys(%$deps)); + if($pkgdeps{$arch}) { _merge($pkgdeps{$arch}, $deps); } + else { $pkgdeps{$arch} = $deps; } + } + + # ArchLinux now has a separate array for dependencies that we only + # need for checking (aka "testing"). Older perl METAs do not + # have this separated. Force any test modules to be checkdepends. + if(!$pkgdeps{'checkdepends'} && $pkgname !~ /\Aperl-test-/) { + my $checkdeps = {}; + _merge($checkdeps, _yankcheckers($pkgdeps{$_})) for(qw/makedepends depends/); + $pkgdeps{'checkdepends'} = $checkdeps; + } + + # We at least require perl, if nothing else. + unless(grep { scalar(keys(%$_)) > 0 } values(%pkgdeps)) { + $pkgdeps{'depends'}{'perl'} = 0; + } + + _mergedups(@pkgdeps{'makedepends', 'checkdepends'}); + _mergedups(@pkgdeps{'depends', 'makedepends'}); + + # Convert all deps into arrays of strings. + for my $deptype (keys(%pkgdeps)) { + $pkgdeps{$deptype} = _stringify($pkgdeps{$deptype}); + } + + return \%pkgdeps; +} + +#---HELPER FUNCTION--- +sub _stringify +{ + my ($deps) = @_; + + my @depstrs; + for my $pkg (sort(keys(%$deps))) { + my $ver = $deps->{$pkg}; + my $str = ($ver eq '0' ? $pkg : "$pkg>=$ver"); + push(@depstrs, $str); + } + + return \@depstrs; +} + +sub _distsofmods +{ + my (@mods) = @_; + + return () if(@mods == 0); + @mods = _nocore(@mods); + + my $var = _vardir(); + open(my $fh, '<', "$var/cpanmods") + or die "$PROG: failed to open $var/cpanmods: $!"; + + my %mods = map { ($_ => 1) } @mods; + my %dists; + local $/ = ''; + + RECLOOP: + while(my $rec = <$fh>) { + last RECLOOP unless(keys %mods > 0); + + my($dist, @mvs) = split(/\n/, $rec); + MODLOOP: + for(@mvs){ + my($m) = split; + my $fnd = delete($mods{$m}) or next; + $dists{$m} = $dist; + } + } + + my @lost = keys %mods; + if(@lost){ + for my $m (@lost){ + print STDERR "$PROG: failed to find module $m\n"; + } + exit 1; + } + + return %dists; +} + +sub _nocore +{ + my (@mods) = @_; + + my $path = _vardir() . '/coremods'; + open(my $if, '<', $path) or die "$PROG: open $path: $!"; + + my %mods = map { ($_ => 1) } @mods; + while(<$if>){ + my ($m) = split; + delete $mods{$m}; + } + + close($if); + return keys %mods; +} + +sub _vardir +{ + return $ENV{'PKGVAR'} + or die "$PROG: PKGVAR env variable is unset\n"; +} + +#----------------------------------------------------------------------------- + +package main; + +use File::Basename qw(basename dirname); +use File::Spec::Functions qw(catfile catdir); +use File::Find qw(find); + +use JSON::XS qw(decode_json); # for META.json +use YAML::XS (); # for META.yml +use Pod::Select (); # search POD for description + +use Digest::MD5 (); # for md5sums & sha512sums +use Digest::SHA (); + +sub main +{ + my $distpath = shift() or die "Usage: $PROG [path to cpan dist file]\n"; + my $dir = dirname($distpath); + my $file = basename($distpath); + my $info = distinfo($file); + + chsrcdir(catdir($dir, 'src'), $file); + $dir = extractdist($file); + + my $meta = loadmeta($dir); + my $desc = $meta->{'abstract'}; + if(!$desc || $desc eq '~' || $desc eq 'unknown') { + $meta->{'abstract'} = distdesc($dir, $info->{'mod'}); + } + + my ($name, $ver) = Convert::dist2pkg(@{$info}{'name', 'ver'}); + my $deps = Convert::prereqs($name, $meta->{'prereqs'}); + + my %pbvars = + ('pkgver' => $ver, + 'pkgdesc' => $meta->{'abstract'}, + 'arch' => (xsdist($dir) ? ['i686', 'x86_64'] : 'any'), + 'md5sums' => md5sums($file), + 'sha512sums' => sha512sums($file), + 'distdir' => $dir, + %$deps, + ); + + # Since this is a perl distribution, use the perl-pkg template. + printf("template\nperl-pkg %s\n\n", (-f "$dir/Build.PL" ? "MB" : "MM")); + print("options\n!emptydirs\n\n"); + + printmeta(\%pbvars); + return 0; +} + +# Create the src/ directory and tarball symlink. Then chdir into it. + +sub chsrcdir +{ + my ($srcdir, $distfile) = @_; + + if (-e $srcdir) { + system("rm", "-fr", $srcdir) == 0 or die "failed to rm $srcdir\n"; + } + mkdir $srcdir or die "mkdir $srcdir: $!"; + chdir($srcdir) or die "chdir $srcdir: $!"; + unless(-f $distfile) { + symlink(catfile('..', $distfile), $distfile) or die "symlink $distfile: $!"; + } + + return $srcdir; +} + +sub distinfo +{ + my ($distfile) = @_; + + my @c = split(/-/, $distfile); + my $ver = pop(@c); + my $name = join(q{-}, @c); + my $mod = $name; + $mod =~ s/-/::/g; + return { 'name' => $name, 'ver' => $ver, 'mod' => $mod }; +} + +sub extractdist +{ + my ($file) = @_; + + system("bsdtar -xf $file"); + die "$PROG: bsdtar failed to extract $file\n" unless($? == 0); + + opendir(my $srcdir, '.') or die "opendir: $!"; + my @dirs = grep { -d $_ && !/\A[.]/ } readdir($srcdir); + closedir($srcdir); + + die("$PROG: many dirs (@dirs) inside the tarball $file\n") + if(@dirs > 1); + die("$PROG: no dirs found in tarball $file\n") if(@dirs == 0); + return $dirs[0]; +} + +sub printmeta +{ + my ($pbvars) = @_; + while(my ($name, $val) = each(%$pbvars)) { + if(!defined($val) || $val eq q{}) { + warn("$PROG: warning: $name is undefined\n"); + $val = q{}; + } + print($name, "\n"); + print("$_\n") for (ref $val ? @$val : $val); + print("\n"); + } + + # TODO: autodetect license type + printf("license\n%s\n\n", join("\n", qw/PerlArtistic GPL/)); +} + +sub loadmeta +{ + my ($distdir) = @_; + + for my $metaext (qw/json yml/) { + my $path = "$distdir/META.$metaext"; + next unless -f $path; + + open(my $metafh, '<', $path) or die "open: $!"; + my $meta = do { local $/; <$metafh> }; + close($metafh); + + $meta = ($metaext eq 'json' ? decode_json($meta) : + $metaext eq 'yml' ? YAML::XS::Load($meta) : + die "internal error: unknown \$metaext: $metaext"); + + upgrademeta($meta); + return $meta; + } + + return undef; +} + +sub upgrademeta +{ + my ($meta) = @_; + + return if(exists($meta->{'prereqs'})); + + my $prereqs; + $prereqs->{'configure'}{'requires'} = delete($meta->{'configure_requires'}); + $prereqs->{'build'}{'requires'} = delete($meta->{'build_requires'}); + $prereqs->{'runtime'}{'requires'} = delete($meta->{'requires'}); + + $meta->{'prereqs'} = $prereqs; + return; +} + +sub xsdist +{ + my ($dir) = @_; + my $isxs; + find({ 'wanted' => sub { $isxs = 1 if(/[.]xs$/) }, 'no_chdir' => 1 }, $dir); + return $isxs; +} + +#----------------------------------------------------------------------------- + +sub distdesc +{ + my ($dir, $modname) = @_; + return _poddesc($dir, $modname) || _readmedesc($dir, $modname); +} + +sub _poddesc +{ + my ($dir, $modname) = @_; + + my $podselect = Pod::Select->new; + $podselect->select('NAME'); + + my $modpath = $modname; $modpath =~ s{::}{/}g; + my $moddir = dirname($modpath); + my $modfile = basename($modpath); + + # First check under lib/ for a "properly" pathed module, with + # nested directories. Then search desperately for a .pm file that + # matches the module's last name component. + + my @possible = glob("$dir/{lib/,}{$moddir/,}$modfile.{pod,pm}"); + + PODSEARCH: + for my $podpath (@possible) { + next PODSEARCH unless(-f $podpath); + + # Read the NAME section of the POD into a scalar. + my $namesect = q{}; + open(my $podfile, '<', $podpath) or next PODSEARCH; + open(my $podout, '>', \$namesect) or die "open: $!"; + + $podselect->parse_from_filehandle($podfile, $podout); + + close($podfile); + close($podout) or die "close: $!"; + + next PODSEARCH unless($namesect); + + # Remove formatting codes. + $namesect =~ s{ [IBCLEFSXZ] <(.*?)> }{$1}gxms; + $namesect =~ s{ [IBCLEFSXZ] <<(.*?)>> }{$1}gxms; + + # The short desc is on a line beginning with 'Module::Name - ' + return $1 if($namesect =~ / ^ \s* $modname [ -]+ ([^\n]+) /xms); + } + + return undef; +} + +#---HELPER FUNCTION--- +sub _readmedesc +{ + my ($dir, $modname) = @_; + + my $path = catfile($dir, 'README'); + return undef unless(-f $path); + open(my $fh, '<', $path) or die "open: $!"; + + while (<$fh>) { + chomp; + next unless((/\ANAME/ ... /\A[A-Z]+/) + && / \A \s* ${modname} [\s\-]+ (.+) \z /x); + return $1; + } + + close $fh; + return undef; +} + +#----------------------------------------------------------------------------- + +sub md5sums +{ + return [ map { + open(my $fh, '<', $_) or die "open: $!"; + my $md5 = Digest::MD5->new()->addfile($fh)->hexdigest; + } @_ ] +} + +sub sha512sums +{ + return [ map { + my $sha = Digest::SHA->new(512)->addfile($_)->hexdigest; + } @_ ] +} + +exit main(@ARGV); diff --git a/metas/perl.d/scrapecore b/metas/perl.d/scrapecore new file mode 100755 index 0000000..2e1aba3 --- /dev/null +++ b/metas/perl.d/scrapecore @@ -0,0 +1,241 @@ +#!/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) || q{}; + push @mods, [ $mod, $ver ]; + } + 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'}/var"; + my $path = "$var/cpanmods"; + open(my $if, '<', $path) or die("open $path: $!"); + + 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, [qw/ Config 1/]; + +@mods = coreonly(@mods); +for my $mv (@mods){ print "@$mv\n"; } |