diff options
Diffstat (limited to 'preps/perl.d')
| -rwxr-xr-x | preps/perl.d/fetchcpan | 60 | ||||
| -rwxr-xr-x | preps/perl.d/perl-dist | 617 | ||||
| -rwxr-xr-x | preps/perl.d/perl-pkgbuild | 120 | ||||
| -rwxr-xr-x | preps/perl.d/scrapecore | 241 |
4 files changed, 1038 insertions, 0 deletions
diff --git a/preps/perl.d/fetchcpan b/preps/perl.d/fetchcpan new file mode 100755 index 0000000..076599b --- /dev/null +++ b/preps/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/preps/perl.d/perl-dist b/preps/perl.d/perl-dist new file mode 100755 index 0000000..407403d --- /dev/null +++ b/preps/perl.d/perl-dist @@ -0,0 +1,617 @@ +#!/usr/bin/env perl + +use warnings 'FATAL' => 'all'; +use strict; + +my $PROG = 'preps/perl.d/perl-dist'; +my $PBPROG = 'perl-pkgbuild'; + +sub DBG {} +if(exists $ENV{'GENDBG'}){ + no warnings 'redefine'; + *DBG = sub { print STDERR "$PROG: DBG: ", @_ }; +} + +package Convert; + +*DBG = *main::DBG; + +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)) { + DBG("requires $name $ver\n"); + my $cver = $Module::CoreList::version{$]}{$name}; + + if($name eq 'perl') { + $pkgdeps{'perl'} = _perldepver($ver); + }elsif($cver){ + DBG("perl core has $name $cver\n"); + my $vobj = eval { version->parse($ver) }; + $cver = version->parse($cver); + if($vobj > $cver){ + push @mods, $name; + } + }else{ + push @mods, $name; + } + } + + my %dists = _distsofmods(@mods); + while(my ($mod, $dist) = each %dists) { + DBG("$mod is provided by $dist\n"); + 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); + DBG("depends on $pkgname>=$pkgdeps{$pkgname}\n"); + } + + 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 = {}; + for(qw/makedepends depends/){ + _merge($checkdeps, _yankcheckers($pkgdeps{$_})) + } + $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; + return %dists unless(@lost); + + for my $m (@lost){ + print STDERR "$PROG: failed to find module $m\n"; + } + exit 1; +} + +sub _nocore +{ + my(@mods) = @_; + + my $path = _vardir() . '/coremods'; + unless(-f $path){ + print STDERR "$PROG: error: $path is missing. +****************************************************************************** + You must generate it with genpkg's metas/perl.d/scrapecore script. Run it + against the source distribution of perl that is currently being packaged. +****************************************************************************** +"; + exit 1; + } + 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 rel2abs); +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 + +sub printdata +{ + my($pbvars) = @_; + print "options\n!emptydirs\n\n"; + printmeta($pbvars); + return; +} + +sub writepb +{ + my($ddir) = @_; + my $dtype = (-f "$ddir/Build.PL" ? "MB" : "MM"); + if(system $PBPROG => $dtype){ + return $? >> 8; + }else{ + return 0; + } +} + +sub main +{ + my $distpath = shift or die "Usage: $PROG [path to cpan dist file]\n"; + $distpath = rel2abs($distpath); + my $dir = dirname($distpath); + my $file = basename($distpath); + my $info = distinfo($file); + + chsrcdir(catdir($dir, 'src'), $file); + my $distdir = extractdist($file); + + my $meta = loadmeta($distdir); + my $desc = $meta->{'abstract'}; + if(!$desc || $desc eq '~' || $desc eq 'unknown'){ + $meta->{'abstract'} = distdesc($distdir, $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($distdir) ? ['i686', 'x86_64'] : 'any'), + 'distdir' => $distdir, + %$deps, + ); + + chdir $dir or die "chdir: $!"; + + my $ret = writepb($dir); + if($ret){ + print STDERR "$PROG: failed to write PKGBUILD: error $ret\n"; + return 1; + } + + printdata(\%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); + die "failed to rm $srcdir\n" unless($? == 0); + } + 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; +} + +exit main(@ARGV); diff --git a/preps/perl.d/perl-pkgbuild b/preps/perl.d/perl-pkgbuild new file mode 100755 index 0000000..80a92e4 --- /dev/null +++ b/preps/perl.d/perl-pkgbuild @@ -0,0 +1,120 @@ +#!/usr/bin/env perl + +use warnings 'FATAL' => 'all'; +use strict; + +my $PROG = 'perl-pkgbuild'; + +sub putpkgbuild +{ + my($sect, $subsect, $text) = @_; + open my $pipe, '|-', 'putpkgtree' => 'PKGBUILD', $sect, $subsect + or die "open putpkgtree: $!"; + print $pipe $text; + close $pipe or exit $? >> 8; +} + +sub putfuncs +{ + my($funcs) = @_; + for my $f (keys %$funcs){ + my $sects = $funcs->{$f}; + while(my ($s, $txt) = each %$sects){ + putpkgbuild($f, $s, $txt); + } + } +} + +sub startfunc +{ + my($name) = @_; + return <<"ENDTXT"; +${name}() +( + cd "\$_distdir" +ENDTXT +} + +sub functxt +{ + my $fmt = shift; + $fmt .= "\n" unless($fmt =~ /\n\z/); + my $txt = sprintf $fmt, @_; + $txt =~ s/^/ /gm; + return $txt; +} + +sub main +{ + if(@_ == 0 || ($_[0] ne 'MM' && $_[0] ne 'MB')){ + print STDERR qq{usage: $PROG ["MM" or "MB"]\n}; + return 1; + } + + my $type = shift; + my($script, $make, $iargs); + my @badenv = qw/PERL5LIB/; + my @exports = qw/PERL_MM_USE_DEFAULT=1/; + if($type eq 'MM'){ + $script = 'Makefile.PL'; + $make = 'make'; + $iargs = q{INSTALLDIRS=vendor DESTDIR="$pkgdir"}; + push @exports, 'PERL_AUTOINSTALL=--skipdeps'; + push @badenv, 'PERL_MM_OPT'; + }else{ + $script = 'Build.PL'; + $make = './Build'; + $iargs = q{installdirs=vendor destdir="$pkgdir"}; + push @badenv, 'PERL_MB_OPT', 'MODULEBUILDRC=/dev/null'; + } + + my %funcs; + my @fnames = qw/build check package/; + for my $f (@fnames){ + $funcs{$f}{'beg'} = startfunc($f); + # Module::Build uses env vars for each stage of Build + if($type eq 'MB'){ + $funcs{$f}{'beg'} = <<"ENDTXT"; +export @exports +unset @badenv +ENDTXT + } + } + + # ExtUtils::MakeMaker only uses env vars for Makefile.PL + if($type eq 'MM'){ + $funcs{'build'}{'beg'} .= functxt(<<'ENDTXT', "@exports", "@badenv"); +export %s +unset %s +ENDTXT + } + + $funcs{'build'}{'body'} = functxt(<<'ENDTXT', $script, $make); +/usr/bin/perl %s +%s +ENDTXT + + $funcs{'check'}{'body'} = functxt("%s test", $make); + + $funcs{'package'}{'body'} = functxt(<<'ENDTXT', $make, $iargs); +%s install %s +find "$pkgdir" -name .packlist -o -name perllocal.pod -delete +ENDTXT + + for my $f (@fnames){ + $funcs{$f}{'end'} = ")\n"; + } + putfuncs(\%funcs); + + putpkgbuild('suffix', 'body', <<'ENDTXT'); +# Local Variables: +# mode: shell-script +# sh-basic-offset: 2 +# End: +# vim:set ts=2 sw=2 et: +ENDTXT + + return 0; +} + +exit main(@ARGV); diff --git a/preps/perl.d/scrapecore b/preps/perl.d/scrapecore new file mode 100755 index 0000000..25f5c80 --- /dev/null +++ b/preps/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'}/.genpkg/var"; + my $path = "$var/cpanmods"; + 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, [qw/ Config 1/]; + +@mods = coreonly(@mods); +for my $mv (@mods){ print "@$mv\n"; } |