Commit | Line | Data |
dad3338c |
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 |
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 %Modules); |
b78893c9 |
12 | use Cwd; |
13 | |
14 | use List::Util qw(max); |
dad3338c |
15 | |
16 | our $packagefile = '02packages.details.txt'; |
17 | |
18 | sub usage () { |
19 | die <<USAGE; |
b78893c9 |
20 | $0 |
21 | $0 -t home1[:label] home2[:label] ... |
22 | |
23 | Report which core modules are outdated. |
dad3338c |
24 | To be run at the root of a perl source tree. |
b78893c9 |
25 | |
dad3338c |
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) |
b78893c9 |
31 | -t : display in tabular form CPAN vs one or more perl source trees |
dad3338c |
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 | |
b78893c9 |
42 | getopts('fhvt'); |
dad3338c |
43 | our $opt_h and usage; |
b78893c9 |
44 | our $opt_t; |
45 | |
46 | my @sources = @ARGV ? @ARGV : '.'; |
47 | die "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 |
57 | our $opt_f || !-f $packagefile and get_package_details; |
dad3338c |
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 ' '; |
b78893c9 |
64 | next if 1../^\s*$/; # skip header |
dad3338c |
65 | $cpanversions{$p} = $v; |
66 | } |
67 | close $fh; |
68 | |
b78893c9 |
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 | for my $dist (sort keys %Modules) { |
79 | next unless $Modules{$dist}{CPAN}; |
80 | for my $file (get_module_files($dist)) { |
81 | next if $file !~ /\.pm\z/ or $file =~ m{^t/} or $file =~ m{/t/}; |
82 | my $vcore = '!EXIST'; |
83 | $vcore = MM->parse_version($file) // 'undef' if -f $file; |
84 | my $module = $file; |
85 | $module =~ s/\.pm\z//; |
86 | # some heuristics to figure out the module name from the file name |
87 | $module =~ s{^(lib|ext)/}{} |
88 | and $1 eq 'ext' |
89 | and ( $module =~ s{^(.*)/lib/\1\b}{$1}, |
90 | $module =~ s{(\w+)/\1\b}{$1}, |
91 | $module =~ s{^Encode/encoding}{encoding}, |
92 | $module =~ s{^MIME/Base64/QuotedPrint}{MIME/QuotedPrint}, |
93 | $module =~ s{^List/Util/lib/Scalar}{Scalar}, |
94 | ); |
95 | $module =~ s{/}{::}g; |
96 | my $vcpan = $cpanversions{$module} // 'undef'; |
97 | $results{$dist}{$file}{$label} = $vcore; |
98 | $results{$dist}{$file}{CPAN} = $vcpan; |
99 | } |
100 | } |
101 | |
102 | chdir $olddir or die "chdir $olddir: $!\n"; |
103 | } |
104 | |
105 | # output %results in the requested format |
106 | |
107 | my @labels = ((map $_->[1], @sources), 'CPAN' ); |
108 | |
109 | if ($opt_t) { |
110 | my %changed; |
111 | my @fields; |
112 | for my $dist (sort keys %results) { |
113 | for my $file (sort keys %{$results{$dist}}) { |
114 | my @versions = @{$results{$dist}{$file}}{@labels}; |
115 | for (0..$#versions) { |
116 | $fields[$_] = max($fields[$_], |
117 | length $versions[$_], |
118 | length $labels[$_], |
119 | length '!EXIST' |
120 | ); |
121 | } |
122 | if (our $opt_v or grep $_ ne $versions[0], @versions) { |
123 | $changed{$dist} = 1; |
124 | } |
125 | } |
126 | } |
127 | printf "%*s ", $fields[$_], $labels[$_] for 0..$#labels; |
128 | print "\n"; |
129 | printf "%*s ", $fields[$_], '-' x length $labels[$_] for 0..$#labels; |
130 | print "\n"; |
131 | |
132 | my $field_total; |
133 | $field_total += $_ + 1 for @fields; |
134 | |
135 | for my $dist (sort keys %results) { |
136 | next unless $changed{$dist}; |
137 | print " " x $field_total, " $dist\n"; |
138 | for my $file (sort keys %{$results{$dist}}) { |
139 | my @versions = @{$results{$dist}{$file}}{@labels}; |
140 | for (0..$#versions) { |
141 | printf "%*s ", $fields[$_], $versions[$_]//'!EXIST' |
142 | } |
143 | print " $file\n"; |
144 | } |
145 | } |
146 | } |
147 | else { |
148 | for my $dist (sort keys %results) { |
149 | print "Module $dist...\n"; |
150 | for my $file (sort keys %{$results{$dist}}) { |
151 | my ($vcpan, $vcore) = @{$results{$dist}{$file}}{@labels}; |
152 | if (our $opt_v or $vcore ne $vcpan) { |
153 | print " $file: core=$vcore, cpan=$vcpan\n"; |
154 | } |
dad3338c |
155 | } |
156 | } |
157 | } |