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
  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;