This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Pluralize "Modules and Pragma" to "Modules and Pragmata"
[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     => 'New Modules and Pragmata',
13   updated => 'Updated Modules and Pragmata',
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             or die "failed to parse $_ section";
212         [$_, $s];
213     } keys %sections;
214
215     for my $s (keys %sections) {
216       my $m = "${s}_modules";
217
218       $self->{$m} = [sort {
219         lc $a->[0] cmp lc $b->[0]
220       } @{ $self->{$m} }];
221     }
222
223     return;
224   }
225
226   sub _parse_new_section {
227     my ($self, $section) = @_;
228
229     $self->{new_modules} = $self->_parse_section($section => sub {
230       my ($el) = @_;
231
232       my ($first, $second) = @{ $el }[2, 3];
233       my ($ver) = $second =~ /(\d[^\s]+)\s+has\s+been/;
234
235       return [ $first->[2], undef, $ver ];
236     });
237
238     return;
239   }
240
241   sub _parse_updated_section {
242     my ($self, $section) = @_;
243
244     $self->{updated_modules} = $self->_parse_section($section => sub {
245       my ($el) = @_;
246
247       my ($first, $second) = @{ $el }[2, 3];
248       my $module = $first->[2];
249       my ($old, $new) = $second =~
250           /from\s+(?:version\s+)?(\d[^\s]+)\s+to\s+(\d[^\s]+?)\.?$/;
251
252       warn "Unable to extract old or new version of $module from perldelta"
253         if !defined $old || !defined $new;
254
255       return [ $module, $old, $new ];
256     });
257
258     return;
259   }
260
261   sub _parse_removed_section {
262     my ($self, $section) = @_;
263     $self->{removed_modules} = $self->_parse_section($section => sub {
264       my ($el) = @_;
265
266       my ($first, $second) = @{ $el }[2, 3];
267       my ($old) = $second =~ /was\s+(\d[^\s]+?)\.?$/;
268
269       return [ $first->[2], $old, undef ];
270     });
271
272     return;
273   }
274
275   sub _parse_section {
276     my ($self, $section, $parser) = @_;
277
278     my $items = $self->_look_down($section => sub {
279       my ($el) = @_;
280       return unless ref $el && $el->[0] =~ /^item-/
281           && @{ $el } > 2 && ref $el->[2];
282       return unless $el->[2]->[0] eq 'C';
283
284       return 1;
285     });
286
287     return [map { $parser->($_) } @{ $items }];
288   }
289
290   sub _look_down {
291     my ($self, $pod, $predicate) = @_;
292     my @pod = @{ $pod };
293
294     my @l;
295     while (my $el = shift @pod) {
296       push @l, $el if $predicate->($el);
297       if (ref $el) {
298         my @el = @{ $el };
299         splice @el, 0, 2;
300         unshift @pod, @el if @el;
301       }
302     }
303
304     return @l ? \@l : undef;
305   }
306
307   sub _look_for_section {
308     my ($self, $pod, $section) = @_;
309
310     my $level;
311     $self->_look_for_range($pod,
312       sub {
313         my ($el) = @_;
314         my ($heading) = $el->[0] =~ /^head(\d)$/;
315         my $f = $heading && $el->[2] =~ /^\Q$section\E/;
316         $level = $heading if $f && !$level;
317         return $f;
318       },
319       sub {
320         my ($el) = @_;
321         $el->[0] =~ /^head(\d)$/ && $1 <= $level;
322       },
323     );
324   }
325
326   sub _look_for_range {
327     my ($self, $pod, $start_predicate, $stop_predicate) = @_;
328
329     my @l;
330     for my $el (@{ $pod }) {
331       if (@l) {
332         return \@l if $stop_predicate->($el);
333       }
334       else {
335         next unless $start_predicate->($el);
336       }
337       push @l, $el;
338     }
339
340     return;
341   }
342 }
343
344 run;