fix dynamic generation skip bug

[scpubgit/System-Introspector-Report.git] / lib / System / Introspector / Report / Publish / MediaWiki / Parser.pm

package System::Introspector::Report::Publish::MediaWiki::Parser;
use Moo;
use HTML::Zoom;

my $_rx_front       = qr{\A<!--\s+SI:};
my $_rx_end         = qr{\s+-->\Z};
my $_rx_table_begin = qr{ $_rx_front TABLE \s+ begin \s+ }x;
my $_rx_table_end   = qr{ $_rx_front TABLE \s+ end \s+ }x;
my $_rx_title_begin = qr{ $_rx_front TITLE \s+ begin \s+ }x;
my $_rx_title_end   = qr{ $_rx_front TITLE \s+ end \s+ }x;
my $_rx_any_begin   = qr{ $_rx_front (TABLE|TITLE) \s+ begin \s }x;
my $_rx_id          = qr{(\S+)};

sub parse {
  my ($self, $body) = @_;
  my $lines = [split m{\n}, $body];
  my $parts = [];
  my $state = '_parse_text';
  while (@$lines) {
    $state = $self->$state($lines, $parts);
  }
  return $parts;
}

sub _parse_table {
  my ($self, $lines, $done) = @_;
  my ($id, $title) = $self->_read_title($lines);
  my $description = [];
  $self->_parse_text($lines, $description);
  my $report = $self->_read_report($lines, $id);
  $report->{title} = $title;
  $report->{description} = $description;
  push @$done, $report;
  return '_parse_text';
}

sub _read_report {
  my ($self, $lines, $id) = @_;
  shift(@$lines) =~ m{ $_rx_table_begin \Q$id\E $_rx_end }x
    or die "Expected table for '$id' after title\n";
  my @report_lines;
  while (@$lines) {
    my $line = shift @$lines;
    if ($line =~ m{ $_rx_table_end $_rx_id $_rx_end }x) {
      return $self->_inflate_report(join('', @report_lines), $id);
    }
    push @report_lines, $line;
  }
  die "Missing end of '$id' report\n";
}

my $_is_type = sub {
  my ($markup, $type, $tag) = @_;
  my $next = $markup->peek;
  return $markup->next
    if not($next) or (
      ($next->{name} || '') eq $tag
      and ($next->{type} || '') eq uc($type)
    );
  return undef;
};

my $_collect_content = sub {
  my ($stream, $type) = @_;
  my @events;
  until ($stream->$_is_type(close => $type)) {
    my $next = $stream->next;
    if ($next->{type} eq 'OPEN' and $next->{name} eq 'br') {
      push @events, { type => 'TEXT', raw => "\n" };
    }
    else {
      push @events, $next;
    }
  }
  return HTML::Zoom->from_events(\@events)->to_html;
};

my $_get_class = sub {
  my ($event, $rx) = @_;
  my $class = $event->{attrs}{class} || '';
  if ($class =~ $rx) {
    return $1;
  }
  return undef;
};

sub _inflate_columns {
  my ($self, $stream) = @_;
  my $user_col_idx = 0;
  my @columns;
  while (my $next = $stream->next) {
    if (my $ev = $stream->$_is_type(open => 'th')) {
      my $key   = $ev->$_get_class(qr{si-colhead-(\S+)});
      my $label = $stream->$_collect_content('th');
      push @columns, {
        key => defined($key) ? $key : '__usercol_' . $user_col_idx++,
        label => $label,
        defined($key) ? () : (user => 1),
      };
    }
    elsif ($stream->$_is_type(close => 'tr')) {
      last;
    }
  }
  return @columns;
}

sub _inflate_rows {
  my ($self, $stream, $cols) = @_;
  my @rows;
  my $user_col_orph_idx = 0;
  while (my $next = $stream->next) {
    if ($stream->$_is_type(open => 'tr')) {
      push @rows, {};
      next;
    }
    if (my $ev = $stream->$_is_type(open => 'td')) {
      my $key;
      if ($#$cols >= scalar keys %{$rows[-1]}) {
          $key = $cols->[scalar keys %{$rows[-1]}]{key};
      }
      else {
        my $newcol = {
          key  => "__usercol_orph_" . $user_col_orph_idx++,
          user => 1,
        };
        push @$cols, $newcol;
        $key = $newcol->{key};
      }
      my $value = $stream->$_collect_content('td');
      $rows[-1]{$key} = $value;
    }
  }
  return \@rows;
}

sub _inflate_report {
  my ($self, $table, $id) = @_;
  my $markup  = HTML::Zoom->from_html($table);
  my $stream  = $markup->to_stream;
  my @columns = $self->_inflate_columns($stream);
  my $rows    = $self->_inflate_rows($stream, \@columns);
  return {
    id      => [split m{:}, $id],
    columns => [@columns],
    rows    => $rows,
  };
}

sub _read_title {
  my ($self, $lines) = @_;
  my $start_line = shift @$lines;
  $start_line =~ m{ $_rx_title_begin ($_rx_id) $_rx_end }x
    or die "Unable to parse table start: $start_line\n";
  my $id = $1;
  my $title_line = shift @$lines;
  $title_line =~ m{ \A == \s+ (.+) \s+ == \Z }x
    or die "Unable to parse title line: $title_line\n";
  my $title = $1;
  my $end_line = shift(@$lines);
  $end_line =~ m{ $_rx_title_end \Q$id\E $_rx_end }x
    or die "Missing title end marker, found: $end_line\n";
  return $id, $title;
}

sub _parse_text {
  my ($self, $lines, $done) = @_;
  while (@$lines) {
    if ($lines->[0] =~ m{ $_rx_any_begin $_rx_id $_rx_end }x) {
      return '_parse_table';
    }
    my $line = shift @$lines;
    chomp $line;
    push @$done, $line;
  }
  return undef;
}

1;