summaryrefslogtreecommitdiffstats
path: root/misc
diff options
context:
space:
mode:
Diffstat (limited to 'misc')
-rwxr-xr-xmisc/perlcore174
1 files changed, 58 insertions, 116 deletions
diff --git a/misc/perlcore b/misc/perlcore
index 6eb25ae..0f1a2a2 100755
--- a/misc/perlcore
+++ b/misc/perlcore
@@ -5,28 +5,6 @@ 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($@);
- die qq{$path:$. bad version string "$_"\n};
- }
-
- close($fh);
- return undef;
-}
-
# ----------------------------------------
package CoreDist;
@@ -34,83 +12,17 @@ package CoreDist;
use File::Basename qw(basename);
use File::Find qw();
*findfile = *File::Find::find;
+*findver = *main::findver;
-sub modname
+sub pathmod
{
- 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;
+ my($p) = @_;
+ for ($p){
+ s{^lib/}{};
+ s{[.]pm$}{};
+ s{/}{::}g;
}
-
- 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);
+ return $p;
}
# scans a directory full of nicely separated dist. directories.
@@ -122,20 +34,19 @@ sub scan_distroot
closedir $cpand;
my @found;
- for my $ddir (map { "$distroot/$_/" } @dists){
- $ddir .= 'lib/' if(-d "$ddir/lib");
+ for my $ddir (map { "$distroot/$_" } @dists){
+ for("$ddir/lib"){
+ $ddir = $_ if(-d $_);
+ }
my $finder = sub {
return unless(/[.]pm$/);
return if(m{/t/});
my $p = $_;
- s/^\Q$ddir\E//;
- s{^lib/}{};
- s{[.]pm$}{};
- s{/}{::}g;
- my $m = $_;
+ s{^\Q$ddir\E/}{};
+ my $m = pathmod($_);
- my $v = Common::evalver($p, $m);
+ my $v = findver($p, $m);
if($v){
push @found, [ $m, $v ];
}else{
@@ -162,6 +73,7 @@ use File::Find qw();
use File::stat;
*findfile = *File::Find::find;
+*findver = *main::findver;
sub findmods
{
@@ -201,7 +113,7 @@ sub findmods
$mod =~ s{\A$libdir}{};
$mod =~ s{/}{::}g;
- my $ver = Common::evalver($path, $mod);
+ my $ver = findver($path, $mod);
if($ver){
push @mods, [ $mod, $ver ];
}else{
@@ -215,7 +127,29 @@ sub findmods
package main;
-sub _delmods
+sub findver
+{
+ 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($@);
+ die qq{$path:$. bad version string "$_"\n};
+ }
+
+ close($fh);
+ return undef;
+}
+
+sub delmods
{
my $coreonly = shift;
for(@_){
@@ -225,27 +159,35 @@ sub _delmods
return;
}
-sub printmods
+sub nocpan
{
my($mods, $mpath) = @_;
my %coreonly = map { @$_ } @$mods;
# Remove mods from the set which are also available from CPAN.
- {
- local $/ = qq{\n\n};
- open my $if, '<', $mpath or die "open $mpath failed: $!";
- while(<$if>){
- my($dist, @dms) = split /\n/;
- _delmods(\%coreonly, @dms);
- }
- close $if;
+ local $/ = qq{\n\n};
+ open my $if, '<', $mpath or die "open $mpath failed: $!";
+ while(<$if>){
+ my(undef, @dms) = split /\n/;
+ delmods(\%coreonly, @dms);
}
+ close $if;
+
+ return \%coreonly;
+}
+
+sub printmods
+{
+ my($mods, $mpath) = @_;
+ my $coreonly = nocpan($mods, $mpath);
# Print a * in the third column for core-only modules.
for my $mv (@$mods){
my($m, $v) = @$mv;
- printf "%s\n", join q{ }, $m, $v, ($coreonly{$m} ? q{*} : ());
+ printf "%s\n", join q{ }, $m, $v, ($coreonly->{$m} ? q{*} : ());
}
+
+ return;
}
sub main