This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add some sanity checking to corelist-perldelta.pl
authorFlorian Ragwitz <rafl@debian.org>
Thu, 24 Mar 2011 14:20:07 +0000 (15:20 +0100)
committerFlorian Ragwitz <rafl@debian.org>
Thu, 24 Mar 2011 16:15:12 +0000 (17:15 +0100)
It can now generate a diff between what's in perldelta and what's in
Module::CoreList for a given range of releases. It's not quite perfect yet, but
already useful.

Porting/corelist-perldelta.pl

index 381f2fa..426e09d 100755 (executable)
@@ -6,6 +6,13 @@ 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;
 
@@ -55,18 +62,21 @@ sub run {
   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";
   }
@@ -74,7 +84,7 @@ sub run {
   exit 0;
 }
 
-sub do_generate {
+sub corelist_delta {
   my ($old, $new) = @_;
   my $corelist = \%Module::CoreList::version;
 
@@ -116,10 +126,217 @@ sub do_generate {
     }
   }
 
-  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($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;