| 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 | } |