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