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; |
93b00636 FR |
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 | ); | |
603f4ea0 | 16 | |
88e14305 DG |
17 | my $deprecated; |
18 | ||
19 | #--------------------------------------------------------------------------# | |
20 | ||
21 | sub 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 | ||
27 | sub 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 | ||
36 | sub 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 | ||
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 | ||
2a19fd14 FR |
61 | sub 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 | 87 | sub 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 | ||
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 | } | |
2a19fd14 | 340 | } |
88e14305 | 341 | |
2a19fd14 | 342 | run; |