This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Updated corecpan.pl for the new module layout
[perl5.git] / Porting / corecpan.pl
CommitLineData
dad3338c
RGS
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.
b78893c9 4# with -t option, can compare multiple source trees in tabular form.
dad3338c
RGS
5
6use 5.9.0;
7use strict;
8use Getopt::Std;
9use ExtUtils::MM_Unix;
10use lib 'Porting';
392c9d37 11use Maintainers qw(get_module_files reload_manifest %Modules);
b78893c9
DM
12use Cwd;
13
14use List::Util qw(max);
dad3338c
RGS
15
16our $packagefile = '02packages.details.txt';
17
18sub usage () {
19 die <<USAGE;
b78893c9
DM
20$0
21$0 -t home1[:label] home2[:label] ...
22
23Report which core modules are outdated.
dad3338c 24To be run at the root of a perl source tree.
b78893c9 25
dad3338c
RGS
26Options :
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)
b78893c9 31-t : display in tabular form CPAN vs one or more perl source trees
dad3338c
RGS
32USAGE
33}
34
35sub 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
b78893c9 42getopts('fhvt');
dad3338c 43our $opt_h and usage;
b78893c9
DM
44our $opt_t;
45
46my @sources = @ARGV ? @ARGV : '.';
47die "Too many directories speficied 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
c16639b5 57our $opt_f || !-f $packagefile and get_package_details;
dad3338c
RGS
58
59# Load the package details. All of them.
60my %cpanversions;
61open my $fh, $packagefile or die $!;
62while (<$fh>) {
63 my ($p, $v) = split ' ';
b78893c9 64 next if 1../^\s*$/; # skip header
dad3338c
RGS
65 $cpanversions{$p} = $v;
66}
67close $fh;
68
b78893c9
DM
69my %results;
70
71# scan source tree(s) and CPAN module list, and put results in %results
72
73foreach my $source (@sources) {
74 my ($srcdir, $label) = @$source;
75 my $olddir = getcwd();
76 chdir $srcdir or die "chdir $srcdir: $!\n";
77
392c9d37
DM
78 # load the MANIFEST file in the new directory
79 reload_manifest;
80
b78893c9
DM
81 for my $dist (sort keys %Modules) {
82 next unless $Modules{$dist}{CPAN};
83 for my $file (get_module_files($dist)) {
19e87f22
DM
84 next if $file !~ /(\.pm|_pm.PL)\z/
85 or $file =~ m{^t/} or $file =~ m{/t/};
b78893c9
DM
86 my $vcore = '!EXIST';
87 $vcore = MM->parse_version($file) // 'undef' if -f $file;
19e87f22
DM
88
89 # get module name from filename to lookup CPAN version
b78893c9 90 my $module = $file;
19e87f22 91 $module =~ s/\_pm.PL\z//;
b78893c9
DM
92 $module =~ s/\.pm\z//;
93 # some heuristics to figure out the module name from the file name
36512bd8
JV
94 $module =~ s{^(lib|ext|dist|cpan)/}{}
95 and $1 =~ /(?:ext|dist|cpan)/
f6e59a58
DM
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/}{},
b78893c9
DM
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
116my @labels = ((map $_->[1], @sources), 'CPAN' );
117
118if ($opt_t) {
119 my %changed;
120 my @fields;
2061eafe 121 for my $dist (sort { lc $a cmp lc $b } keys %results) {
b78893c9
DM
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
2061eafe 144 for my $dist (sort { lc $a cmp lc $b } keys %results) {
b78893c9
DM
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}
156else {
2061eafe 157 for my $dist (sort { lc $a cmp lc $b } keys %results) {
b78893c9
DM
158 print "Module $dist...\n";
159 for my $file (sort keys %{$results{$dist}}) {
2d373db1 160 my ($vcore, $vcpan) = @{$results{$dist}{$file}}{@labels};
b78893c9
DM
161 if (our $opt_v or $vcore ne $vcpan) {
162 print " $file: core=$vcore, cpan=$vcpan\n";
163 }
dad3338c
RGS
164 }
165 }
166}