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 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 );
  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         $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   }
 340 }
 341
 342 run;