| 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 | |
| 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.017001 5.017002 <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 |
| 32 | |
| 33 | my %sections = ( |
| 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 = ( |
| 40 | new => 'New Modules and Pragmata', |
| 41 | updated => 'Updated Modules and Pragmata', |
| 42 | removed => 'Removed Modules and Pragmata', |
| 43 | ); |
| 44 | |
| 45 | my $deprecated; |
| 46 | |
| 47 | #--------------------------------------------------------------------------# |
| 48 | |
| 49 | sub added { |
| 50 | my ($mod, $old_v, $new_v) = @_; |
| 51 | say "=item *\n"; |
| 52 | say "L<$mod> $new_v has been added to the Perl core.\n"; |
| 53 | } |
| 54 | |
| 55 | sub updated { |
| 56 | my ($mod, $old_v, $new_v) = @_; |
| 57 | say "=item *\n"; |
| 58 | say "L<$mod> has been upgraded from version $old_v to $new_v.\n"; |
| 59 | if ( $deprecated->{$mod} ) { |
| 60 | say "NOTE: L<$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) = @_; |
| 66 | say "=item *\n"; |
| 67 | say "C<$mod> has been removed from the Perl core. Prior version was $old_v.\n"; |
| 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 | |
| 89 | sub run { |
| 90 | my %opt = (mode => 'generate'); |
| 91 | |
| 92 | GetOptions(\%opt, |
| 93 | 'mode|m:s', # 'generate', 'check' |
| 94 | ); |
| 95 | |
| 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]; |
| 101 | |
| 102 | if ( $opt{mode} eq 'generate' ) { |
| 103 | do_generate($old => $new); |
| 104 | } |
| 105 | elsif ( $opt{mode} eq 'check' ) { |
| 106 | do_check(\*ARGV, $old => $new); |
| 107 | } |
| 108 | else { |
| 109 | die "Unrecognized mode '$opt{mode}'\n"; |
| 110 | } |
| 111 | |
| 112 | exit 0; |
| 113 | } |
| 114 | |
| 115 | sub corelist_delta { |
| 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}; |
| 126 | my $old_ver = $corelist->{$old}{$k}; |
| 127 | my $new_ver = $corelist->{$new}{$k}; |
| 128 | # in core but not in last corelist |
| 129 | if ( ! exists $corelist->{$old}{$k} ) { |
| 130 | push @new, [$k, undef, $new_ver]; |
| 131 | } |
| 132 | # otherwise just pragmas or modules |
| 133 | else { |
| 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 | } |
| 144 | } |
| 145 | } |
| 146 | |
| 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 | } |
| 155 | } |
| 156 | |
| 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 | |
| 164 | generate_section($titles{new}, \&added, @{ $added }); |
| 165 | generate_section($titles{updated}, \&updated, @{ $pragmas }, @{ $modules }); |
| 166 | generate_section($titles{removed}, \&removed, @{ $removed }); |
| 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 | |
| 183 | require Algorithm::Diff; |
| 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, |
| 219 | # just the nodes within it |
| 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) = @{ $_ }; |
| 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 | |
| 245 | $self->${\"_parse_${t}_section"}($s) |
| 246 | } map { |
| 247 | my $s = $self->_look_for_section($pod => $sections{$_}) |
| 248 | or die "failed to parse $_ section"; |
| 249 | [$_, $s]; |
| 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) = @_; |
| 351 | my ($heading) = $el->[0] =~ /^head(\d)$/; |
| 352 | my $f = $heading && $el->[2] =~ /^$section/; |
| 353 | $level = $heading if $f && !$level; |
| 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 | } |
| 379 | } |
| 380 | |
| 381 | run; |