+{
+ 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;
+ }
+}