#!perl
use 5.010;
use strict;
use warnings;
use lib 'Porting';
use Maintainers qw/%Modules/;
use Module::CoreList;
use Getopt::Long;
use Algorithm::Diff;
my %sections = (
new => 'New Modules and Pragmata',
updated => 'Updated Modules and Pragma',
removed => 'Removed Modules and Pragmata',
);
my $deprecated;
#--------------------------------------------------------------------------#
sub added {
my ($mod, $old_v, $new_v) = @_;
say "=item *\n";
say "C<$mod> $new_v has been added to the Perl core.\n";
}
sub updated {
my ($mod, $old_v, $new_v) = @_;
say "=item *\n";
say "C<$mod> has been upgraded from version $old_v to $new_v.\n";
if ( $deprecated->{$mod} ) {
say "NOTE: C<$mod> is deprecated and may be removed from a future version of Perl.\n";
}
}
sub removed {
my ($mod, $old_v, $new_v) = @_;
say "=item *\n";
say "C<$mod> has been removed from the Perl core. Prior version was $old_v.\n";
}
sub generate_section {
my ($title, $item_sub, @mods ) = @_;
return unless @mods;
say "=head2 $title\n";
say "=over 4\n";
for my $tuple ( sort { lc($a->[0]) cmp lc($b->[0]) } @mods ) {
my ($mod,$old_v,$new_v) = @$tuple;
$old_v //= q('undef');
$new_v //= q('undef');
$item_sub->($mod, $old_v, $new_v);
}
say "=back\n";
}
#--------------------------------------------------------------------------#
sub run {
my %opt = (mode => 'generate');
GetOptions(\%opt,
'mode|m:s', # 'generate', 'check'
);
# by default, compare latest two version in CoreList;
my @versions = sort keys %Module::CoreList::version;
my ($old, $new) = (shift @ARGV, shift @ARGV);
$old ||= $versions[-2];
$new ||= $versions[-1];
if ( $opt{mode} eq 'generate' ) {
do_generate($old => $new);
}
elsif ( $opt{mode} eq 'check' ) {
do_check(\*ARGV, $old => $new);
}
else {
die "Unrecognized mode '$opt{mode}'\n";
}
exit 0;
}
sub corelist_delta {
my ($old, $new) = @_;
my $corelist = \%Module::CoreList::version;
$deprecated = $Module::CoreList::deprecated{$new};
my (@new,@deprecated,@removed,@pragmas,@modules);
# %Modules defines what is currently in core
for my $k ( keys %Modules ) {
next unless exists $corelist->{$new}{$k};
my $old_ver = $corelist->{$old}{$k};
my $new_ver = $corelist->{$new}{$k};
# in core but not in last corelist
if ( ! exists $corelist->{$old}{$k} ) {
push @new, [$k, undef, $new_ver];
}
# otherwise just pragmas or modules
else {
my $old_ver = $corelist->{$old}{$k};
my $new_ver = $corelist->{$new}{$k};
next unless defined $old_ver && defined $new_ver && $old_ver ne $new_ver;
my $tuple = [ $k, $old_ver, $new_ver ];
if ( $k eq lc $k ) {
push @pragmas, $tuple;
}
else {
push @modules, $tuple;
}
}
}
# in old corelist, but not this one => removed
# N.B. This is exhaustive -- not just what's in %Modules, so modules removed from
# distributions will show up here, too. Some person will have to review to see what's
# important. That's the best we can do without a historical Maintainers.pl
for my $k ( keys %{ $corelist->{$old} } ) {
if ( ! exists $corelist->{$new}{$k} ) {
push @removed, [$k, $corelist->{$old}{$k}, undef];
}
}
return (\@new, \@removed, \@pragmas, \@modules);
}
sub do_generate {
my ($old, $new) = @_;
my ($added, $removed, $pragmas, $modules) = corelist_delta($old => $new);
generate_section($sections{new}, \&added, @{ $added });
generate_section($sections{updated}, \&updated, @{ $pragmas }, @{ $modules });
generate_section($sections{removed}, \&removed, @{ $removed });
}
sub do_check {
my ($in, $old, $new) = @_;
my $delta = DeltaParser->new($in);
my ($added, $removed, $pragmas, $modules) = corelist_delta($old => $new);
for my $ck (['new', $delta->new_modules, $added],
['removed', $delta->removed_modules, $removed],
['updated', $delta->updated_modules, [@{ $modules }, @{ $pragmas }]]) {
my @delta = @{ $ck->[1] };
my @corelist = sort { lc $a->[0] cmp lc $b->[0] } @{ $ck->[2] };
printf $ck->[0] . ":\n";
my $diff = Algorithm::Diff->new(map {
[map { join q{ } => grep defined, @{ $_ } } @{ $_ }]
} \@delta, \@corelist);
while ($diff->Next) {
next if $diff->Same;
my $sep = '';
if (!$diff->Items(2)) {
printf "%d,%dd%d\n", $diff->Get(qw( Min1 Max1 Max2 ));
} elsif(!$diff->Items(1)) {
printf "%da%d,%d\n", $diff->Get(qw( Max1 Min2 Max2 ));
} else {
$sep = "---\n";
printf "%d,%dc%d,%d\n", $diff->Get(qw( Min1 Max1 Min2 Max2 ));
}
print "< $_\n" for $diff->Items(1);
print $sep;
print "> $_\n" for $diff->Items(2);
}
print "\n";
}
}
{
package DeltaParser;
use Pod::Simple::SimpleTree;
sub new {
my ($class, $input) = @_;
my $self = bless {} => $class;
my $parsed_pod = Pod::Simple::SimpleTree->new->parse_file($input)->root;
splice @{ $parsed_pod }, 0, 2; # we don't care about the document structure,
# just the nods within it
$self->_parse_delta($parsed_pod);
return $self;
}
for my $k (keys %sections) {
no strict 'refs';
my $m = "${k}_modules";
*$m = sub { $_[0]->{$m} };
}
sub _parse_delta {
my ($self, $pod) = @_;
map {
my ($t, $s) = @{ $_ };
$self->${\"_parse_${t}_section"}($s)
} map {
my $s = $self->_look_for_section($pod => $sections{$_});
$s ? [$_, $s] : $s
} keys %sections;
for my $s (keys %sections) {
my $m = "${s}_modules";
$self->{$m} = [sort {
lc $a->[0] cmp lc $b->[0]
} @{ $self->{$m} }];
}
return;
}
sub _parse_new_section {
my ($self, $section) = @_;
$self->{new_modules} = $self->_parse_section($section => sub {
my ($el) = @_;
my ($first, $second) = @{ $el }[2, 3];
my ($ver) = $second =~ /(\d[^\s]+)\s+has\s+been/;
return [ $first->[2], undef, $ver ];
});
return;
}
sub _parse_updated_section {
my ($self, $section) = @_;
$self->{updated_modules} = $self->_parse_section($section => sub {
my ($el) = @_;
my ($first, $second) = @{ $el }[2, 3];
my $module = $first->[2];
my ($old, $new) = $second =~
/from\s+(?:version\s+)?(\d[^\s]+)\s+to\s+(\d[^\s]+?)\.?$/;
warn "Unable to extract old or new version of $module from perldelta"
if !defined $old || !defined $new;
return [ $module, $old, $new ];
});
return;
}
sub _parse_removed_section {
my ($self, $section) = @_;
$self->{removed_modules} = $self->_parse_section($section => sub {
my ($el) = @_;
my ($first, $second) = @{ $el }[2, 3];
my ($old) = $second =~ /was\s+(\d[^\s]+?)\.?$/;
return [ $first->[2], $old, undef ];
});
return;
}
sub _parse_section {
my ($self, $section, $parser) = @_;
my $items = $self->_look_down($section => sub {
my ($el) = @_;
return unless ref $el && $el->[0] =~ /^item-/
&& @{ $el } > 2 && ref $el->[2];
return unless $el->[2]->[0] eq 'C';
return 1;
});
return [map { $parser->($_) } @{ $items }];
}
sub _look_down {
my ($self, $pod, $predicate) = @_;
my @pod = @{ $pod };
my @l;
while (my $el = shift @pod) {
push @l, $el if $predicate->($el);
if (ref $el) {
my @el = @{ $el };
splice @el, 0, 2;
unshift @pod, @el if @el;
}
}
return @l ? \@l : undef;
}
sub _look_for_section {
my ($self, $pod, $section) = @_;
my $level;
$self->_look_for_range($pod,
sub {
my ($el) = @_;
my $f = $el->[0] =~ /^head(\d)$/ && $el->[2] eq $section;
$level = $1 if $f && !$level;
return $f;
},
sub {
my ($el) = @_;
$el->[0] =~ /^head(\d)$/ && $1 <= $level;
},
);
}
sub _look_for_range {
my ($self, $pod, $start_predicate, $stop_predicate) = @_;
my @l;
for my $el (@{ $pod }) {
if (@l) {
return \@l if $stop_predicate->($el);
}
else {
next unless $start_predicate->($el);
}
push @l, $el;
}
return;
}
}
run;