diff options
Diffstat (limited to 'misc/perlcore')
| -rwxr-xr-x | misc/perlcore | 174 |
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 |