use lib 'Porting';
use Maintainers qw/%Modules/;
use Module::CoreList;
+use Getopt::Long;
+require Algorithm::Diff;
-my $corelist = \%Module::CoreList::version;
-my @versions = sort keys %$corelist;
+my %sections = (
+ new => 'New Modules and Pragmata',
+ updated => 'Updated Modules and Pragmata',
+ removed => 'Removed Modules and Pragmata',
+);
-# by default, compare latest two version in CoreList;
-my ($old, $new) = @ARGV;
-$old ||= $versions[-2];
-$new ||= $versions[-1];
+my $deprecated;
-say "=head2 Updated Modules\n";
-say "=over 4\n";
+#--------------------------------------------------------------------------#
-for my $mod ( sort { lc $a cmp lc $b } keys %Modules ) {
- my $old_ver = $corelist->{$old}{$mod};
- my $new_ver = $corelist->{$new}{$mod};
- next unless defined $old_ver && defined $new_ver && $old_ver ne $new_ver;
- say "=item C<$mod>\n";
- say "Upgraded from version $old_ver to $new_ver.\n";
+sub added {
+ my ($mod, $old_v, $new_v) = @_;
+ say "=item *\n";
+ say "C<$mod> $new_v has been added to the Perl core.\n";
}
-say "=back\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{$_})
+ or die "failed to parse $_ section";
+ [$_, $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 ($heading) = $el->[0] =~ /^head(\d)$/;
+ my $f = $heading && $el->[2] =~ /^\Q$section\E/;
+ $level = $heading 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;
https://perl5.git.perl.org / perl5.git / blobdiff