Set default static inline for Netware/config.wc.
[perl.git] / 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|_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:\n" unless ($distname_printed++);
163                 print "\t$file: core=$vcore, cpan=$vcpan\n";
164             }
165         }
166     }
167 }