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