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 Module::CoreList;
   8 use Getopt::Long;
   9 require Algorithm::Diff;
  10
  11 my %sections = (
  12   new     => 'New Modules and Pragma',
  13   updated => 'Updated Modules and Pragma',
  14   removed => 'Removed Modules and Pragma',
  15 );
  16
  17 my $deprecated;
  18
  19 #--------------------------------------------------------------------------#
  20
  21 sub added {
  22   my ($mod, $old_v, $new_v) = @_;
  23   say "=item *\n";
  24   say "C<$mod> $new_v has been added to the Perl core.\n";
  25 }
  26
  27 sub updated {
  28   my ($mod, $old_v, $new_v) = @_;
  29   say "=item *\n";
  30   say "C<$mod> has been upgraded from version $old_v to $new_v.\n";
  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) = @_;
  38   say "=item *\n";
  39   say "C<$mod> has been removed from the Perl core.  Prior version was $old_v.\n";
  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
  61 sub run {
  62   my %opt = (mode => 'generate');
  63
  64   GetOptions(\%opt,
  65     'mode|m:s', # 'generate', 'check'
  66   );
  67
  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];
  73
  74   if ( $opt{mode} eq 'generate' ) {
  75     do_generate($old => $new);
  76   }
  77   elsif ( $opt{mode} eq 'check' ) {
  78     do_check(\*ARGV, $old => $new);
  79   }
  80   else {
  81     die "Unrecognized mode '$opt{mode}'\n";
  82   }
  83
  84   exit 0;
  85 }
  86
  87 sub corelist_delta {
  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};
  98     my $old_ver = $corelist->{$old}{$k};
  99     my $new_ver = $corelist->{$new}{$k};
 100     # in core but not in last corelist
 101     if ( ! exists $corelist->{$old}{$k} ) {
 102       push @new, [$k, undef, $new_ver];
 103     }
 104     # otherwise just pragmas or modules
 105     else {
 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       }
 116     }
 117   }
 118
 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     }
 127   }
 128
 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             or die "failed to parse $_ section";
 212         [$_, $s];
 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) = @_;
 314         my ($heading) = $el->[0] =~ /^head(\d)$/;
 315         my $f = $heading && $el->[2] =~ /^\Q$section\E/;
 316         $level = $heading if $f && !$level;
 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   }
 342 }
 343
 344 run;