This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
corelist-perldelta.pl now requires Algorithm::Diff instead of using it.
[perl5.git] / Porting / corelist-perldelta.pl
CommitLineData
603f4ea0
DG
1#!perl
2use 5.010;
3use strict;
4use warnings;
5use lib 'Porting';
6use Maintainers qw/%Modules/;
7use Module::CoreList;
2a19fd14 8use Getopt::Long;
010a5dd8 9require Algorithm::Diff;
93b00636
FR
10
11my %sections = (
86c08a2c 12 new => 'New Modules and Pragma',
93b00636 13 updated => 'Updated Modules and Pragma',
86c08a2c 14 removed => 'Removed Modules and Pragma',
93b00636 15);
603f4ea0 16
88e14305
DG
17my $deprecated;
18
19#--------------------------------------------------------------------------#
20
21sub added {
22 my ($mod, $old_v, $new_v) = @_;
0f200d9f
FR
23 say "=item *\n";
24 say "C<$mod> $new_v has been added to the Perl core.\n";
88e14305
DG
25}
26
27sub updated {
28 my ($mod, $old_v, $new_v) = @_;
0f200d9f
FR
29 say "=item *\n";
30 say "C<$mod> has been upgraded from version $old_v to $new_v.\n";
88e14305
DG
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
36sub removed {
37 my ($mod, $old_v, $new_v) = @_;
0f200d9f
FR
38 say "=item *\n";
39 say "C<$mod> has been removed from the Perl core. Prior version was $old_v.\n";
88e14305
DG
40}
41
42sub 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
2a19fd14
FR
61sub run {
62 my %opt = (mode => 'generate');
63
64 GetOptions(\%opt,
93b00636 65 'mode|m:s', # 'generate', 'check'
2a19fd14
FR
66 );
67
93b00636
FR
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];
2a19fd14 73
93b00636 74 if ( $opt{mode} eq 'generate' ) {
2a19fd14 75 do_generate($old => $new);
88e14305 76 }
93b00636
FR
77 elsif ( $opt{mode} eq 'check' ) {
78 do_check(\*ARGV, $old => $new);
79 }
88e14305 80 else {
2a19fd14
FR
81 die "Unrecognized mode '$opt{mode}'\n";
82 }
83
84 exit 0;
85}
86
93b00636 87sub corelist_delta {
2a19fd14
FR
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};
88e14305
DG
98 my $old_ver = $corelist->{$old}{$k};
99 my $new_ver = $corelist->{$new}{$k};
2a19fd14
FR
100 # in core but not in last corelist
101 if ( ! exists $corelist->{$old}{$k} ) {
102 push @new, [$k, undef, $new_ver];
88e14305 103 }
2a19fd14 104 # otherwise just pragmas or modules
88e14305 105 else {
2a19fd14
FR
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 }
88e14305
DG
116 }
117 }
603f4ea0 118
2a19fd14
FR
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 }
88e14305 127 }
88e14305 128
93b00636
FR
129 return (\@new, \@removed, \@pragmas, \@modules);
130}
131
132sub 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
141sub 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 {
a71535a8
FR
210 my $s = $self->_look_for_section($pod => $sections{$_})
211 or die "failed to parse $_ section";
212 [$_, $s];
93b00636
FR
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) = @_;
86c08a2c
FR
314 my ($heading) = $el->[0] =~ /^head(\d)$/;
315 my $f = $heading && $el->[2] =~ /^\Q$section\E/;
316 $level = $heading if $f && !$level;
93b00636
FR
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 }
2a19fd14 342}
88e14305 343
2a19fd14 344run;