diff options
Diffstat (limited to 'misc')
| -rwxr-xr-x | misc/perlcore | 249 |
1 files changed, 249 insertions, 0 deletions
diff --git a/misc/perlcore b/misc/perlcore new file mode 100755 index 0000000..8fe1530 --- /dev/null +++ b/misc/perlcore @@ -0,0 +1,249 @@ +#!/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)); |