Porting/corecpan.pl

   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 }