| 1 |
#!perl |
| 2 |
# Reports, in a perl source tree, which dual-lived core modules have not the |
| 3 |
# same version than the corresponding module on CPAN. |
| 4 |
# with -t option, can compare multiple source trees in tabular form. |
| 5 |
|
| 6 |
use 5.9.0; |
| 7 |
use strict; |
| 8 |
use Getopt::Std; |
| 9 |
use ExtUtils::MM_Unix; |
| 10 |
use lib 'Porting'; |
| 11 |
use Maintainers qw(get_module_files reload_manifest %Modules); |
| 12 |
use Cwd; |
| 13 |
|
| 14 |
use List::Util qw(max); |
| 15 |
|
| 16 |
our $packagefile = '02packages.details.txt'; |
| 17 |
|
| 18 |
sub usage () { |
| 19 |
die <<USAGE; |
| 20 |
$0 |
| 21 |
$0 -t home1[:label] home2[:label] ... |
| 22 |
|
| 23 |
Report which core modules are outdated. |
| 24 |
To be run at the root of a perl source tree. |
| 25 |
|
| 26 |
Options : |
| 27 |
-h : help |
| 28 |
-v : verbose (print all versions of all files, not only those which differ) |
| 29 |
-f : force download of $packagefile from CPAN |
| 30 |
(it's expected to be found in the current directory) |
| 31 |
-t : display in tabular form CPAN vs one or more perl source trees |
| 32 |
USAGE |
| 33 |
} |
| 34 |
|
| 35 |
sub get_package_details () { |
| 36 |
my $url = 'http://www.cpan.org/modules/02packages.details.txt.gz'; |
| 37 |
unlink $packagefile; |
| 38 |
system("wget $url && gunzip $packagefile.gz") == 0 |
| 39 |
or die "Failed to get package details\n"; |
| 40 |
} |
| 41 |
|
| 42 |
getopts('fhvt'); |
| 43 |
our $opt_h and usage; |
| 44 |
our $opt_t; |
| 45 |
|
| 46 |
my @sources = @ARGV ? @ARGV : '.'; |
| 47 |
die "Too many directories specified without -t option\n" |
| 48 |
if @sources != 1 and ! $opt_t; |
| 49 |
|
| 50 |
@sources = map { |
| 51 |
# handle /home/user/perl:bleed style labels |
| 52 |
my ($dir,$label) = split /:/; |
| 53 |
$label = $dir unless defined $label; |
| 54 |
[ $dir, $label ]; |
| 55 |
} @sources; |
| 56 |
|
| 57 |
our $opt_f || !-f $packagefile and get_package_details; |
| 58 |
|
| 59 |
# Load the package details. All of them. |
| 60 |
my %cpanversions; |
| 61 |
open my $fh, '<', $packagefile or die $!; |
| 62 |
while (<$fh>) { |
| 63 |
my ($p, $v) = split ' '; |
| 64 |
next if 1../^\s*$/; # skip header |
| 65 |
$cpanversions{$p} = $v; |
| 66 |
} |
| 67 |
close $fh; |
| 68 |
|
| 69 |
my %results; |
| 70 |
|
| 71 |
# scan source tree(s) and CPAN module list, and put results in %results |
| 72 |
|
| 73 |
foreach my $source (@sources) { |
| 74 |
my ($srcdir, $label) = @$source; |
| 75 |
my $olddir = getcwd(); |
| 76 |
chdir $srcdir or die "chdir $srcdir: $!\n"; |
| 77 |
|
| 78 |
# load the MANIFEST file in the new directory |
| 79 |
reload_manifest; |
| 80 |
|
| 81 |
for my $dist (sort keys %Modules) { |
| 82 |
next unless $Modules{$dist}{CPAN}; |
| 83 |
for my $file (get_module_files($dist)) { |
| 84 |
next if $file !~ /(\.pm|_pm.PL)\z/ |
| 85 |
or $file =~ m{^t/} or $file =~ m{/t/}; |
| 86 |
my $vcore = '!EXIST'; |
| 87 |
$vcore = MM->parse_version($file) // 'undef' if -f $file; |
| 88 |
|
| 89 |
# get module name from filename to lookup CPAN version |
| 90 |
my $module = $file; |
| 91 |
$module =~ s/\_pm.PL\z//; |
| 92 |
$module =~ s/\.pm\z//; |
| 93 |
# some heuristics to figure out the module name from the file name |
| 94 |
$module =~ s{^(lib|ext|dist|cpan)/}{} |
| 95 |
and $1 =~ /(?:ext|dist|cpan)/ |
| 96 |
and ( |
| 97 |
# ext/Foo-Bar/Bar.pm |
| 98 |
$module =~ s{^(\w+)-(\w+)/\2$}{$1/lib/$1/$2}, |
| 99 |
# ext/Encode/Foo/Foo.pm |
| 100 |
$module =~ s{^(Encode)/(\w+)/\2$}{$1/lib/$1/$2}, |
| 101 |
$module =~ s{^[^/]+/}{}, |
| 102 |
$module =~ s{^lib/}{}, |
| 103 |
); |
| 104 |
$module =~ s{/}{::}g; |
| 105 |
my $vcpan = $cpanversions{$module} // 'undef'; |
| 106 |
$results{$dist}{$file}{$label} = $vcore; |
| 107 |
$results{$dist}{$file}{CPAN} = $vcpan; |
| 108 |
} |
| 109 |
} |
| 110 |
|
| 111 |
chdir $olddir or die "chdir $olddir: $!\n"; |
| 112 |
} |
| 113 |
|
| 114 |
# output %results in the requested format |
| 115 |
|
| 116 |
my @labels = ((map $_->[1], @sources), 'CPAN' ); |
| 117 |
|
| 118 |
if ($opt_t) { |
| 119 |
my %changed; |
| 120 |
my @fields; |
| 121 |
for my $dist (sort { lc $a cmp lc $b } keys %results) { |
| 122 |
for my $file (sort keys %{$results{$dist}}) { |
| 123 |
my @versions = @{$results{$dist}{$file}}{@labels}; |
| 124 |
for (0..$#versions) { |
| 125 |
$fields[$_] = max($fields[$_], |
| 126 |
length $versions[$_], |
| 127 |
length $labels[$_], |
| 128 |
length '!EXIST' |
| 129 |
); |
| 130 |
} |
| 131 |
if (our $opt_v or grep $_ ne $versions[0], @versions) { |
| 132 |
$changed{$dist} = 1; |
| 133 |
} |
| 134 |
} |
| 135 |
} |
| 136 |
printf "%*s ", $fields[$_], $labels[$_] for 0..$#labels; |
| 137 |
print "\n"; |
| 138 |
printf "%*s ", $fields[$_], '-' x length $labels[$_] for 0..$#labels; |
| 139 |
print "\n"; |
| 140 |
|
| 141 |
my $field_total; |
| 142 |
$field_total += $_ + 1 for @fields; |
| 143 |
|
| 144 |
for my $dist (sort { lc $a cmp lc $b } keys %results) { |
| 145 |
next unless $changed{$dist}; |
| 146 |
print " " x $field_total, " $dist\n"; |
| 147 |
for my $file (sort keys %{$results{$dist}}) { |
| 148 |
my @versions = @{$results{$dist}{$file}}{@labels}; |
| 149 |
for (0..$#versions) { |
| 150 |
printf "%*s ", $fields[$_], $versions[$_]//'!EXIST' |
| 151 |
} |
| 152 |
print " $file\n"; |
| 153 |
} |
| 154 |
} |
| 155 |
} |
| 156 |
else { |
| 157 |
for my $dist (sort { lc $a cmp lc $b } keys %results) { |
| 158 |
my $distname_printed = 0; |
| 159 |
for my $file (sort keys %{$results{$dist}}) { |
| 160 |
my ($vcore, $vcpan) = @{$results{$dist}{$file}}{@labels}; |
| 161 |
if (our $opt_v or $vcore ne $vcpan) { |
| 162 |
print "\n$dist ($Modules{$dist}{MAINTAINER}):\n" unless ($distname_printed++); |
| 163 |
print "\t$file: core=$vcore, cpan=$vcpan\n"; |
| 164 |
} |
| 165 |
} |
| 166 |
} |
| 167 |
} |
