use Module::CoreList;
use Getopt::Long;
+=head1 USAGE
+
+ # generate the module changes for the Perl you are currently building
+ ./perl Porting/corelist-perldelta.pl
+
+ # generate a diff between the corelist sections of two perldelta* files:
+ perl Porting/corelist-perldelta.pl --mode=check 5.017001 5.017002 <perl5172delta.pod
+
+=head1 ABOUT
+
+corelist-perldelta.pl is a bit schizophrenic. The part to generate the
+new Perldelta text does not need Algorithm::Diff, but wants to be
+run with the freshly built Perl.
+
+The part to check the diff wants to be run with a Perl that has an up-to-date
+L<Module::CoreList>, but needs the outside L<Algorithm::Diff>.
+
+Ideally, the program will be split into two separate programs, one
+to generate the text and one to show the diff between the
+corelist sections of the last perldelta and the next perldelta.
+
+=cut
+
+my %sections = (
+ new => qr/New Modules and Pragma(ta)?/,
+ updated => qr/Updated Modules and Pragma(ta)?/,
+ removed => qr/Removed Modules and Pragma(ta)?/,
+);
+
+my %titles = (
+ new => 'New Modules and Pragmata',
+ updated => 'Updated Modules and Pragmata',
+ 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";
+ say "L<$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";
+ say "L<$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";
+ say "NOTE: L<$mod> is deprecated and may be removed from a future version of Perl.\n";
}
}
my %opt = (mode => 'generate');
GetOptions(\%opt,
- 'mode|m:s', # 'generate'
+ 'mode|m:s', # 'generate', 'check'
);
- if ( $opt{mode} eq 'generate' ) {
- # by default, compare latest two version in CoreList;
- my @versions = sort keys %Module::CoreList::version;
- my ($old, $new) = @ARGV;
- $old ||= $versions[-2];
- $new ||= $versions[-1];
+ # 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 do_generate {
+sub corelist_delta {
my ($old, $new) = @_;
my $corelist = \%Module::CoreList::version;
}
}
- generate_section("New Modules and Pragmata", \&added, @new);
- generate_section("Pragmata Changes", \&updated, @pragmas);
- generate_section("Updated Modules", \&updated, @modules);
- generate_section("Removed Modules and Pragmata", \&removed, @removed);
+ return (\@new, \@removed, \@pragmas, \@modules);
+}
+
+sub do_generate {
+ my ($old, $new) = @_;
+ my ($added, $removed, $pragmas, $modules) = corelist_delta($old => $new);
+
+ generate_section($titles{new}, \&added, @{ $added });
+ generate_section($titles{updated}, \&updated, @{ $pragmas }, @{ $modules });
+ generate_section($titles{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";
+
+ require Algorithm::Diff;
+ 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 nodes 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) = @{ $_ };
+
+ # Keep the section title if it has one:
+ if( $s->[0]->[0] eq 'head2' ) {
+ #warn "Keeping section title '$s->[0]->[2]'";
+ $titles{ $t } = $s->[0]->[2]
+ if $s->[0]->[2];
+ };
+
+ $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] =~ /^$section/;
+ $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