summaryrefslogtreecommitdiffstats
path: root/misc/perlcore
diff options
context:
space:
mode:
Diffstat (limited to 'misc/perlcore')
-rwxr-xr-xmisc/perlcore249
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));