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