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 %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     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             }
 155         }
 156     }
 157 }