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