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