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 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
  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\z/ or $file =~ m{^t/} or $file =~ m{/t/};
  85             my $vcore = '!EXIST';
  86             $vcore = MM->parse_version($file) // 'undef' if -f $file;
  87             my $module = $file;
  88             $module =~ s/\.pm\z//;
  89             # some heuristics to figure out the module name from the file name
  90             $module =~ s{^(lib|ext)/}{}
  91                 and $1 eq 'ext'
  92                 and (
  93                       # ext/Foo-Bar/Bar.pm
  94                       $module =~ s{^(\w+)-(\w+)/\2$}{$1/lib/$1/$2},
  95                       # ext/Encode/Foo/Foo.pm
  96                       $module =~ s{^(Encode)/(\w+)/\2$}{$1/lib/$1/$2},
  97                       $module =~ s{^[^/]+/}{},
  98                       $module =~ s{^lib/}{},
  99                     );
 100             $module =~ s{/}{::}g;
 101             my $vcpan = $cpanversions{$module} // 'undef';
 102             $results{$dist}{$file}{$label} = $vcore;
 103             $results{$dist}{$file}{CPAN} = $vcpan;
 104         }
 105     }
 106
 107     chdir $olddir or die "chdir $olddir: $!\n";
 108 }
 109
 110 # output %results in the requested format
 111
 112 my @labels = ((map $_->[1], @sources), 'CPAN' );
 113
 114 if ($opt_t) {
 115     my %changed;
 116     my @fields;
 117     for my $dist (sort { lc $a cmp lc $b } keys %results) {
 118         for my $file (sort keys %{$results{$dist}}) {
 119             my @versions = @{$results{$dist}{$file}}{@labels};
 120             for (0..$#versions) {
 121                 $fields[$_] = max($fields[$_],
 122                                   length $versions[$_],
 123                                   length $labels[$_],
 124                                   length '!EXIST'
 125                                 );
 126             }
 127             if (our $opt_v or grep $_ ne $versions[0], @versions) {
 128                 $changed{$dist} = 1;
 129             }
 130         }
 131     }
 132     printf "%*s ", $fields[$_], $labels[$_] for 0..$#labels;
 133     print "\n";
 134     printf "%*s ", $fields[$_], '-' x length $labels[$_] for 0..$#labels;
 135     print "\n";
 136
 137     my $field_total;
 138     $field_total += $_ + 1 for @fields;
 139
 140     for my $dist (sort { lc $a cmp lc $b } keys %results) {
 141         next unless $changed{$dist};
 142         print " " x $field_total, " $dist\n";
 143         for my $file (sort keys %{$results{$dist}}) {
 144             my @versions = @{$results{$dist}{$file}}{@labels};
 145             for (0..$#versions) {
 146                 printf "%*s ", $fields[$_], $versions[$_]//'!EXIST'
 147             }
 148             print "    $file\n";
 149         }
 150     }
 151 }
 152 else {
 153     for my $dist (sort { lc $a cmp lc $b } keys %results) {
 154         print "Module $dist...\n";
 155         for my $file (sort keys %{$results{$dist}}) {
 156             my ($vcore, $vcpan) = @{$results{$dist}{$file}}{@labels};
 157             if (our $opt_v or $vcore ne $vcpan) {
 158                 print "    $file: core=$vcore, cpan=$vcpan\n";
 159             }
 160         }
 161     }
 162 }