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 lib 'dist/Module-CoreList/lib';
   8 use Module::CoreList;
   9 use Getopt::Long;
  10
  11 =head1 USAGE
  12
  13   # generate the module changes for the Perl you are currently building
  14   ./perl -Ilib Porting/corelist-perldelta.pl
  15
  16   # generate a diff between the corelist sections of two perldelta* files:
  17   perl Porting/corelist-perldelta.pl --mode=check 5.017001 5.017002 <perl5172delta.pod
  18
  19 =head1 ABOUT
  20
  21 corelist-perldelta.pl is a bit schizophrenic. The part to generate the
  22 new Perldelta text does not need Algorithm::Diff, but wants to be
  23 run with the freshly built Perl.
  24
  25 The part to check the diff wants to be run with a Perl that has an up-to-date
  26 L<Module::CoreList>, but needs the outside L<Algorithm::Diff>.
  27
  28 Ideally, the program will be split into two separate programs, one
  29 to generate the text and one to show the diff between the
  30 corelist sections of the last perldelta and the next perldelta.
  31
  32 =cut
  33
  34 my %sections = (
  35   new     => qr/New Modules and Pragma(ta)?/,
  36   updated => qr/Updated Modules and Pragma(ta)?/,
  37   removed => qr/Removed Modules and Pragma(ta)?/,
  38 );
  39
  40 my %titles = (
  41   new     => 'New Modules and Pragmata',
  42   updated => 'Updated Modules and Pragmata',
  43   removed => 'Removed Modules and Pragmata',
  44 );
  45
  46 my $deprecated;
  47
  48 #--------------------------------------------------------------------------#
  49
  50 sub added {
  51   my ($mod, $old_v, $new_v) = @_;
  52   say "=item *\n";
  53   say "L<$mod> $new_v has been added to the Perl core.\n";
  54 }
  55
  56 sub updated {
  57   my ($mod, $old_v, $new_v) = @_;
  58   say "=item *\n";
  59   say "L<$mod> has been upgraded from version $old_v to $new_v.\n";
  60   if ( $deprecated->{$mod} ) {
  61     say "NOTE: L<$mod> is deprecated and may be removed from a future version of Perl.\n";
  62   }
  63 }
  64
  65 sub removed {
  66   my ($mod, $old_v, $new_v) = @_;
  67   say "=item *\n";
  68   say "C<$mod> has been removed from the Perl core.  Prior version was $old_v.\n";
  69 }
  70
  71 sub generate_section {
  72   my ($title, $item_sub, @mods ) = @_;
  73   return unless @mods;
  74
  75   say "=head2 $title\n";
  76   say "=over 4\n";
  77
  78   for my $tuple ( sort { lc($a->[0]) cmp lc($b->[0]) } @mods ) {
  79     my ($mod,$old_v,$new_v) = @$tuple;
  80     $old_v //= q('undef');
  81     $new_v //= q('undef');
  82     $item_sub->($mod, $old_v, $new_v);
  83   }
  84
  85   say "=back\n";
  86 }
  87
  88 #--------------------------------------------------------------------------#
  89
  90 sub run {
  91   my %opt = (mode => 'generate');
  92
  93   GetOptions(\%opt,
  94     'mode|m:s', # 'generate', 'check'
  95   );
  96
  97   # by default, compare latest two version in CoreList;
  98   my @versions = sort keys %Module::CoreList::version;
  99   my ($old, $new) = (shift @ARGV, shift @ARGV);
 100   $old ||= $versions[-2];
 101   $new ||= $versions[-1];
 102
 103   if ( $opt{mode} eq 'generate' ) {
 104     do_generate($old => $new);
 105   }
 106   elsif ( $opt{mode} eq 'check' ) {
 107     do_check(\*ARGV, $old => $new);
 108   }
 109   else {
 110     die "Unrecognized mode '$opt{mode}'\n";
 111   }
 112
 113   exit 0;
 114 }
 115
 116 sub corelist_delta {
 117   my ($old, $new) = @_;
 118   my $corelist = \%Module::CoreList::version;
 119
 120   $deprecated = $Module::CoreList::deprecated{$new};
 121
 122   my (@new,@deprecated,@removed,@pragmas,@modules);
 123
 124   # %Modules defines what is currently in core
 125   for my $k ( keys %Modules ) {
 126     next unless exists $corelist->{$new}{$k};
 127     my $old_ver = $corelist->{$old}{$k};
 128     my $new_ver = $corelist->{$new}{$k};
 129     # in core but not in last corelist
 130     if ( ! exists $corelist->{$old}{$k} ) {
 131       push @new, [$k, undef, $new_ver];
 132     }
 133     # otherwise just pragmas or modules
 134     else {
 135       my $old_ver = $corelist->{$old}{$k};
 136       my $new_ver = $corelist->{$new}{$k};
 137       next unless defined $old_ver && defined $new_ver && $old_ver ne $new_ver;
 138       my $tuple = [ $k, $old_ver, $new_ver ];
 139       if ( $k eq lc $k ) {
 140         push @pragmas, $tuple;
 141       }
 142       else {
 143         push @modules, $tuple;
 144       }
 145     }
 146   }
 147
 148   # in old corelist, but not this one => removed
 149   # N.B. This is exhaustive -- not just what's in %Modules, so modules removed from
 150   # distributions will show up here, too.  Some person will have to review to see what's
 151   # important. That's the best we can do without a historical Maintainers.pl
 152   for my $k ( keys %{ $corelist->{$old} } ) {
 153     if ( ! exists $corelist->{$new}{$k} ) {
 154       push @removed, [$k, $corelist->{$old}{$k}, undef];
 155     }
 156   }
 157
 158   return (\@new, \@removed, \@pragmas, \@modules);
 159 }
 160
 161 sub do_generate {
 162   my ($old, $new) = @_;
 163   my ($added, $removed, $pragmas, $modules) = corelist_delta($old => $new);
 164
 165   generate_section($titles{new}, \&added, @{ $added });
 166   generate_section($titles{updated}, \&updated, @{ $pragmas }, @{ $modules });
 167   generate_section($titles{removed}, \&removed, @{ $removed });
 168 }
 169
 170 sub do_check {
 171   my ($in, $old, $new) = @_;
 172
 173   my $delta = DeltaParser->new($in);
 174   my ($added, $removed, $pragmas, $modules) = corelist_delta($old => $new);
 175
 176   for my $ck (['new',     $delta->new_modules, $added],
 177               ['removed', $delta->removed_modules, $removed],
 178               ['updated', $delta->updated_modules, [@{ $modules }, @{ $pragmas }]]) {
 179     my @delta = @{ $ck->[1] };
 180     my @corelist = sort { lc $a->[0] cmp lc $b->[0] } @{ $ck->[2] };
 181
 182     printf $ck->[0] . ":\n";
 183
 184     require Algorithm::Diff;
 185     my $diff = Algorithm::Diff->new(map {
 186       [map { join q{ } => grep defined, @{ $_ } } @{ $_ }]
 187     } \@delta, \@corelist);
 188
 189     while ($diff->Next) {
 190       next if $diff->Same;
 191       my $sep = '';
 192       if (!$diff->Items(2)) {
 193         printf "%d,%dd%d\n", $diff->Get(qw( Min1 Max1 Max2 ));
 194       } elsif(!$diff->Items(1)) {
 195         printf "%da%d,%d\n", $diff->Get(qw( Max1 Min2 Max2 ));
 196       } else {
 197         $sep = "---\n";
 198         printf "%d,%dc%d,%d\n", $diff->Get(qw( Min1 Max1 Min2 Max2 ));
 199       }
 200       print "< $_\n" for $diff->Items(1);
 201       print $sep;
 202       print "> $_\n" for $diff->Items(2);
 203     }
 204
 205     print "\n";
 206   }
 207 }
 208
 209 {
 210   package DeltaParser;
 211   use Pod::Simple::SimpleTree;
 212
 213   sub new {
 214     my ($class, $input) = @_;
 215
 216     my $self = bless {} => $class;
 217
 218     my $parsed_pod = Pod::Simple::SimpleTree->new->parse_file($input)->root;
 219     splice @{ $parsed_pod }, 0, 2; # we don't care about the document structure,
 220                                    # just the nodes within it
 221
 222     $self->_parse_delta($parsed_pod);
 223
 224     return $self;
 225   }
 226
 227   for my $k (keys %sections) {
 228     no strict 'refs';
 229     my $m = "${k}_modules";
 230     *$m = sub { $_[0]->{$m} };
 231   }
 232
 233   sub _parse_delta {
 234     my ($self, $pod) = @_;
 235
 236     map {
 237         my ($t, $s) = @{ $_ };
 238
 239         # Keep the section title if it has one:
 240         if( $s->[0]->[0] eq 'head2' ) {
 241           #warn "Keeping section title '$s->[0]->[2]'";
 242           $titles{ $t } = $s->[0]->[2]
 243               if $s->[0]->[2];
 244         };
 245
 246         $self->${\"_parse_${t}_section"}($s)
 247     } map {
 248         my $s = $self->_look_for_section($pod => $sections{$_})
 249             or die "failed to parse $_ section";
 250         [$_, $s];
 251     } keys %sections;
 252
 253     for my $s (keys %sections) {
 254       my $m = "${s}_modules";
 255
 256       $self->{$m} = [sort {
 257         lc $a->[0] cmp lc $b->[0]
 258       } @{ $self->{$m} }];
 259     }
 260
 261     return;
 262   }
 263
 264   sub _parse_new_section {
 265     my ($self, $section) = @_;
 266
 267     $self->{new_modules} = $self->_parse_section($section => sub {
 268       my ($el) = @_;
 269
 270       my ($first, $second) = @{ $el }[2, 3];
 271       my ($ver) = $second =~ /(\d[^\s]+)\s+has\s+been/;
 272
 273       return [ $first->[2], undef, $ver ];
 274     });
 275
 276     return;
 277   }
 278
 279   sub _parse_updated_section {
 280     my ($self, $section) = @_;
 281
 282     $self->{updated_modules} = $self->_parse_section($section => sub {
 283       my ($el) = @_;
 284
 285       my ($first, $second) = @{ $el }[2, 3];
 286       my $module = $first->[2];
 287       my ($old, $new) = $second =~
 288           /from\s+(?:version\s+)?(\d[^\s]+)\s+to\s+(\d[^\s]+?)\.?$/;
 289
 290       warn "Unable to extract old or new version of $module from perldelta"
 291         if !defined $old || !defined $new;
 292
 293       return [ $module, $old, $new ];
 294     });
 295
 296     return;
 297   }
 298
 299   sub _parse_removed_section {
 300     my ($self, $section) = @_;
 301     $self->{removed_modules} = $self->_parse_section($section => sub {
 302       my ($el) = @_;
 303
 304       my ($first, $second) = @{ $el }[2, 3];
 305       my ($old) = $second =~ /was\s+(\d[^\s]+?)\.?$/;
 306
 307       return [ $first->[2], $old, undef ];
 308     });
 309
 310     return;
 311   }
 312
 313   sub _parse_section {
 314     my ($self, $section, $parser) = @_;
 315
 316     my $items = $self->_look_down($section => sub {
 317       my ($el) = @_;
 318       return unless ref $el && $el->[0] =~ /^item-/
 319           && @{ $el } > 2 && ref $el->[2];
 320       return unless $el->[2]->[0] eq 'C';
 321
 322       return 1;
 323     });
 324
 325     return [map { $parser->($_) } @{ $items }];
 326   }
 327
 328   sub _look_down {
 329     my ($self, $pod, $predicate) = @_;
 330     my @pod = @{ $pod };
 331
 332     my @l;
 333     while (my $el = shift @pod) {
 334       push @l, $el if $predicate->($el);
 335       if (ref $el) {
 336         my @el = @{ $el };
 337         splice @el, 0, 2;
 338         unshift @pod, @el if @el;
 339       }
 340     }
 341
 342     return @l ? \@l : undef;
 343   }
 344
 345   sub _look_for_section {
 346     my ($self, $pod, $section) = @_;
 347
 348     my $level;
 349     $self->_look_for_range($pod,
 350       sub {
 351         my ($el) = @_;
 352         my ($heading) = $el->[0] =~ /^head(\d)$/;
 353         my $f = $heading && $el->[2] =~ /^$section/;
 354         $level = $heading if $f && !$level;
 355         return $f;
 356       },
 357       sub {
 358         my ($el) = @_;
 359         $el->[0] =~ /^head(\d)$/ && $1 <= $level;
 360       },
 361     );
 362   }
 363
 364   sub _look_for_range {
 365     my ($self, $pod, $start_predicate, $stop_predicate) = @_;
 366
 367     my @l;
 368     for my $el (@{ $pod }) {
 369       if (@l) {
 370         return \@l if $stop_predicate->($el);
 371       }
 372       else {
 373         next unless $start_predicate->($el);
 374       }
 375       push @l, $el;
 376     }
 377
 378     return;
 379   }
 380 }
 381
 382 run;