teach sync-with-cpan how to update Maintainers.pl
[perl.git] / Porting / corelist-perldelta.pl
1 #!perl
2 use 5.010;
3 use strict;
4 use warnings;
5 use lib 'Porting';
6 use Maintainers qw/%Modules/;
7 use Module::CoreList;
8 use Getopt::Long;
9
10 =head1 USAGE
11
12   # generate the module changes for the Perl you are currently building
13   ./perl Porting/corelist-perldelta.pl
14   
15   # generate a diff between the corelist sections of two perldelta* files:
16   perl Porting/corelist-perldelta.pl --mode=check 5.17.1 5.17.2 <perl5172delta.pod
17
18 =head1 ABOUT
19
20 corelist-perldelta.pl is a bit schizophrenic. The part to generate the
21 new Perldelta text does not need Algorithm::Diff, but wants to be
22 run with the freshly built Perl.
23
24 The part to check the diff wants to be run with a Perl that has an up-to-date
25 L<Module::CoreList>, but needs the outside L<Algorithm::Diff>.
26
27 Ideally, the program will be split into two separate programs, one
28 to generate the text and one to show the diff between the 
29 corelist sections of the last perldelta and the next perldelta.
30
31 =cut
32
33 my %sections = (
34   new     => qr/New Modules and Pragma(ta)?/,
35   updated => qr/Updated Modules and Pragma(ta)?/,
36   removed => qr/Removed Modules and Pragma(ta)?/,
37 );
38
39 my %titles = (
40   new     => 'New Modules and Pragmata',
41   updated => 'Updated Modules and Pragmata',
42   removed => 'Removed Modules and Pragmata',
43 );
44
45 my $deprecated;
46
47 #--------------------------------------------------------------------------#
48
49 sub added {
50   my ($mod, $old_v, $new_v) = @_;
51   say "=item *\n";
52   say "C<$mod> $new_v has been added to the Perl core.\n";
53 }
54
55 sub updated {
56   my ($mod, $old_v, $new_v) = @_;
57   say "=item *\n";
58   say "C<$mod> has been upgraded from version $old_v to $new_v.\n";
59   if ( $deprecated->{$mod} ) {
60     say "NOTE: C<$mod> is deprecated and may be removed from a future version of Perl.\n";
61   }
62 }
63
64 sub removed {
65   my ($mod, $old_v, $new_v) = @_;
66   say "=item *\n";
67   say "C<$mod> has been removed from the Perl core.  Prior version was $old_v.\n";
68 }
69
70 sub generate_section {
71   my ($title, $item_sub, @mods ) = @_;
72   return unless @mods;
73
74   say "=head2 $title\n";
75   say "=over 4\n";
76
77   for my $tuple ( sort { lc($a->[0]) cmp lc($b->[0]) } @mods ) {
78     my ($mod,$old_v,$new_v) = @$tuple;
79     $old_v //= q('undef');
80     $new_v //= q('undef');
81     $item_sub->($mod, $old_v, $new_v);
82   }
83
84   say "=back\n";
85 }
86
87 #--------------------------------------------------------------------------#
88
89 sub run {
90   my %opt = (mode => 'generate');
91
92   GetOptions(\%opt,
93     'mode|m:s', # 'generate', 'check'
94   );
95
96   # by default, compare latest two version in CoreList;
97   my @versions = sort keys %Module::CoreList::version;
98   my ($old, $new) = (shift @ARGV, shift @ARGV);
99   $old ||= $versions[-2];
100   $new ||= $versions[-1];
101
102   if ( $opt{mode} eq 'generate' ) {
103     do_generate($old => $new);
104   }
105   elsif ( $opt{mode} eq 'check' ) {
106     do_check(\*ARGV, $old => $new);
107   }
108   else {
109     die "Unrecognized mode '$opt{mode}'\n";
110   }
111
112   exit 0;
113 }
114
115 sub corelist_delta {
116   my ($old, $new) = @_;
117   my $corelist = \%Module::CoreList::version;
118
119   $deprecated = $Module::CoreList::deprecated{$new};
120
121   my (@new,@deprecated,@removed,@pragmas,@modules);
122
123   # %Modules defines what is currently in core
124   for my $k ( keys %Modules ) {
125     next unless exists $corelist->{$new}{$k};
126     my $old_ver = $corelist->{$old}{$k};
127     my $new_ver = $corelist->{$new}{$k};
128     # in core but not in last corelist
129     if ( ! exists $corelist->{$old}{$k} ) {
130       push @new, [$k, undef, $new_ver];
131     }
132     # otherwise just pragmas or modules
133     else {
134       my $old_ver = $corelist->{$old}{$k};
135       my $new_ver = $corelist->{$new}{$k};
136       next unless defined $old_ver && defined $new_ver && $old_ver ne $new_ver;
137       my $tuple = [ $k, $old_ver, $new_ver ];
138       if ( $k eq lc $k ) {
139         push @pragmas, $tuple;
140       }
141       else {
142         push @modules, $tuple;
143       }
144     }
145   }
146
147   # in old corelist, but not this one => removed
148   # N.B. This is exhaustive -- not just what's in %Modules, so modules removed from
149   # distributions will show up here, too.  Some person will have to review to see what's
150   # important. That's the best we can do without a historical Maintainers.pl
151   for my $k ( keys %{ $corelist->{$old} } ) {
152     if ( ! exists $corelist->{$new}{$k} ) {
153       push @removed, [$k, $corelist->{$old}{$k}, undef];
154     }
155   }
156
157   return (\@new, \@removed, \@pragmas, \@modules);
158 }
159
160 sub do_generate {
161   my ($old, $new) = @_;
162   my ($added, $removed, $pragmas, $modules) = corelist_delta($old => $new);
163
164   generate_section($titles{new}, \&added, @{ $added });
165   generate_section($titles{updated}, \&updated, @{ $pragmas }, @{ $modules });
166   generate_section($titles{removed}, \&removed, @{ $removed });
167 }
168
169 sub do_check {
170   my ($in, $old, $new) = @_;
171
172   my $delta = DeltaParser->new($in);
173   my ($added, $removed, $pragmas, $modules) = corelist_delta($old => $new);
174
175   for my $ck (['new',     $delta->new_modules, $added],
176               ['removed', $delta->removed_modules, $removed],
177               ['updated', $delta->updated_modules, [@{ $modules }, @{ $pragmas }]]) {
178     my @delta = @{ $ck->[1] };
179     my @corelist = sort { lc $a->[0] cmp lc $b->[0] } @{ $ck->[2] };
180
181     printf $ck->[0] . ":\n";
182
183     require Algorithm::Diff;
184     my $diff = Algorithm::Diff->new(map {
185       [map { join q{ } => grep defined, @{ $_ } } @{ $_ }]
186     } \@delta, \@corelist);
187
188     while ($diff->Next) {
189       next if $diff->Same;
190       my $sep = '';
191       if (!$diff->Items(2)) {
192         printf "%d,%dd%d\n", $diff->Get(qw( Min1 Max1 Max2 ));
193       } elsif(!$diff->Items(1)) {
194         printf "%da%d,%d\n", $diff->Get(qw( Max1 Min2 Max2 ));
195       } else {
196         $sep = "---\n";
197         printf "%d,%dc%d,%d\n", $diff->Get(qw( Min1 Max1 Min2 Max2 ));
198       }
199       print "< $_\n" for $diff->Items(1);
200       print $sep;
201       print "> $_\n" for $diff->Items(2);
202     }
203
204     print "\n";
205   }
206 }
207
208 {
209   package DeltaParser;
210   use Pod::Simple::SimpleTree;
211
212   sub new {
213     my ($class, $input) = @_;
214
215     my $self = bless {} => $class;
216
217     my $parsed_pod = Pod::Simple::SimpleTree->new->parse_file($input)->root;
218     splice @{ $parsed_pod }, 0, 2; # we don't care about the document structure,
219                                    # just the nodes within it
220
221     $self->_parse_delta($parsed_pod);
222
223     return $self;
224   }
225
226   for my $k (keys %sections) {
227     no strict 'refs';
228     my $m = "${k}_modules";
229     *$m = sub { $_[0]->{$m} };
230   }
231
232   sub _parse_delta {
233     my ($self, $pod) = @_;
234
235     map {
236         my ($t, $s) = @{ $_ };
237         
238         # Keep the section title if it has one:
239         if( $s->[0]->[0] eq 'head2' ) {
240           #warn "Keeping section title '$s->[0]->[2]'";
241           $titles{ $t } = $s->[0]->[2]
242               if $s->[0]->[2];
243         };
244
245         $self->${\"_parse_${t}_section"}($s)
246     } map {
247         my $s = $self->_look_for_section($pod => $sections{$_})
248             or die "failed to parse $_ section";
249         [$_, $s];
250     } keys %sections;
251
252     for my $s (keys %sections) {
253       my $m = "${s}_modules";
254
255       $self->{$m} = [sort {
256         lc $a->[0] cmp lc $b->[0]
257       } @{ $self->{$m} }];
258     }
259
260     return;
261   }
262
263   sub _parse_new_section {
264     my ($self, $section) = @_;
265
266     $self->{new_modules} = $self->_parse_section($section => sub {
267       my ($el) = @_;
268
269       my ($first, $second) = @{ $el }[2, 3];
270       my ($ver) = $second =~ /(\d[^\s]+)\s+has\s+been/;
271
272       return [ $first->[2], undef, $ver ];
273     });
274
275     return;
276   }
277
278   sub _parse_updated_section {
279     my ($self, $section) = @_;
280
281     $self->{updated_modules} = $self->_parse_section($section => sub {
282       my ($el) = @_;
283
284       my ($first, $second) = @{ $el }[2, 3];
285       my $module = $first->[2];
286       my ($old, $new) = $second =~
287           /from\s+(?:version\s+)?(\d[^\s]+)\s+to\s+(\d[^\s]+?)\.?$/;
288
289       warn "Unable to extract old or new version of $module from perldelta"
290         if !defined $old || !defined $new;
291
292       return [ $module, $old, $new ];
293     });
294
295     return;
296   }
297
298   sub _parse_removed_section {
299     my ($self, $section) = @_;
300     $self->{removed_modules} = $self->_parse_section($section => sub {
301       my ($el) = @_;
302
303       my ($first, $second) = @{ $el }[2, 3];
304       my ($old) = $second =~ /was\s+(\d[^\s]+?)\.?$/;
305
306       return [ $first->[2], $old, undef ];
307     });
308
309     return;
310   }
311
312   sub _parse_section {
313     my ($self, $section, $parser) = @_;
314
315     my $items = $self->_look_down($section => sub {
316       my ($el) = @_;
317       return unless ref $el && $el->[0] =~ /^item-/
318           && @{ $el } > 2 && ref $el->[2];
319       return unless $el->[2]->[0] eq 'C';
320
321       return 1;
322     });
323
324     return [map { $parser->($_) } @{ $items }];
325   }
326
327   sub _look_down {
328     my ($self, $pod, $predicate) = @_;
329     my @pod = @{ $pod };
330
331     my @l;
332     while (my $el = shift @pod) {
333       push @l, $el if $predicate->($el);
334       if (ref $el) {
335         my @el = @{ $el };
336         splice @el, 0, 2;
337         unshift @pod, @el if @el;
338       }
339     }
340
341     return @l ? \@l : undef;
342   }
343
344   sub _look_for_section {
345     my ($self, $pod, $section) = @_;
346
347     my $level;
348     $self->_look_for_range($pod,
349       sub {
350         my ($el) = @_;
351         my ($heading) = $el->[0] =~ /^head(\d)$/;
352         my $f = $heading && $el->[2] =~ /^$section/;        
353         $level = $heading if $f && !$level;
354         return $f;
355       },
356       sub {
357         my ($el) = @_;
358         $el->[0] =~ /^head(\d)$/ && $1 <= $level;
359       },
360     );
361   }
362
363   sub _look_for_range {
364     my ($self, $pod, $start_predicate, $stop_predicate) = @_;
365
366     my @l;
367     for my $el (@{ $pod }) {
368       if (@l) {
369         return \@l if $stop_predicate->($el);
370       }
371       else {
372         next unless $start_predicate->($el);
373       }
374       push @l, $el;
375     }
376
377     return;
378   }
379 }
380
381 run;