File Coverage

blib/lib/Text/Table/Read/RelationOn/Tiny.pm

Criterion	Covered	Total	%
statement	208	208	100.0
branch	144	148	97.3
condition	27	31	87.1
subroutine	21	21	100.0
pod	11	11	100.0
total	411	419	98.0

package Text::Table::Read::RelationOn::Tiny;

use 5.010_001;
use strict;
use warnings;
use autodie;

use Carp;

# The following must be on the same line to ensure that $VERSION is read
# correctly by PAUSE and installer tools. See docu of 'version'.
use version 0.77; our $VERSION = version->declare("v2.2.5");


sub new {
  my $class = shift;
  $class = ref($class) if ref($class);
  croak("Odd number of arguments") if @_ % 2;
  my %args = @_;
  my $inc      = delete $args{inc}   // "X";
  my $noinc    = delete $args{noinc} // "";
  my $set      = delete $args{set};
  my $eqs      = delete $args{eqs};
  my $ext      = delete $args{ext};
  my $elem_ids = delete $args{elem_ids};
  croak(join(", ", sort(keys(%args))) . ": unexpected argument") if %args;
  croak("inc: must be a scalar")               if ref($inc);
  croak("noinc: must be a scalar")             if ref($noinc);
  s/^\s+// for ($inc, $noinc);
  s/\s+$// for ($inc, $noinc);
  croak("inc and noinc must be different")     if $inc eq $noinc;
  croak("'|' is not allowed for inc or noinc") if $inc eq '|' || $noinc eq '|';
  my $self = {inc    => $inc,
              noinc  => $noinc,
             };
  if (defined($set)) {
    my %seen;
    croak("set: must be an array reference") if ref($set) ne 'ARRAY';
    my $cnt = 1;
    foreach my $e (@$set) {
      if (ref($e)) {
        croak("set: entry $cnt: invalid") if ref($e) ne 'ARRAY';
        croak("set: entry $cnt: array not allowed if eqs is specified") if $eqs;
        croak("set: entry $cnt: array entry must not be empty") if !@{$e};
        foreach my $sub_e (@$e) {
          croak("set: entry $cnt: subarray contains invalid entry")
            if ref($sub_e) || !defined($sub_e);
          croak("set: '$sub_e': duplicate element") if exists($seen{$sub_e});
          $seen{$sub_e} = undef;
        }
      } else {
        croak("set: entry $cnt: invalid") if !defined($e);
        croak("set: '$e': duplicate element") if exists($seen{$e});
        $seen{$e} = undef;
      }
      ++$cnt;
    }
    $self->{prespec} = 1;
  } else {
    croak("eqs: not allowed without argument 'set'") if defined($eqs);
    $self->{prespec} = "";
  }
  if (defined($elem_ids)) {
    croak("elem_ids: not allowed without arguments 'set' and 'ext'") if !(defined($ext) &&
                                                                            defined($set));
    croak("elem_ids: must be a hash ref") if ref($elem_ids) ne 'HASH';
  }
  my $elems;
  my $tabElems;                # elems to be used in table --> indes in @elems
  my $eqIds;
  if ($ext) {
    if ($set) {
      foreach my $e (@$set) {
        croak("set: no subarray allowed if 'ext' is specified") if ref($e);
      }
      if ($elem_ids) {
        croak("elem_ids: wrong number of entries") if keys(%$elem_ids) != @$set;
        foreach my $e (@$set) {
          my $e_id = $elem_ids->{$e};
          croak("elem_ids: '$e': missing value") if !defined($e_id);
          croak("elem_ids: '$e': entry has wrong value") if ($e_id !~ /^\d$/         ||
                                                               !defined($set->[$e_id]) ||
                                                               $set->[$e_id] ne $e);
        }
      } else {
        my $idx = 0;
        $elem_ids = {map {$_ => $idx++} @$set};
      }
      $elems = $set;
    } else {
      croak("ext: not allowed without argument 'set'")
    }
    %$tabElems = %$elem_ids;
  } elsif (ref($set)) {
    my @elems;                         # elems
    my %ids;                           # indices in basic elems
    my @eqs_tmp;

    foreach my $entry (@$set) {
      if (ref($entry)) {
        push(@elems, $entry->[0]);
        $ids{$entry->[0]} = $#elems;
        for (my $j = 1; $j < @$entry; ++$j) {
          my $ent_j = $entry->[$j];
          push(@elems, $ent_j);
          $ids{$ent_j} = $#elems;
        }
        push(@eqs_tmp, $entry) if @$entry > 1;
      } else {
        push(@elems, $entry);
        $ids{$entry} = $#elems;
      }
    }
    croak("Internal error") if (defined($eqs) && @eqs_tmp); # Should never happen.
    $eqs = \@eqs_tmp if @eqs_tmp;
    ($elems, $elem_ids, $tabElems, $eqIds) = (\@elems, \%ids, {%ids}, {});
  }
  if (defined($eqs)) {
    croak("eqs: must be an array ref") if ref($eqs) ne 'ARRAY';
    my %eqIds;                         # idx => array of equivalent idxes
    my %seen;
    foreach my $eqArray (@{$eqs}) {
      croak("eqs: each entry must be an array ref") if ref($eqArray) ne 'ARRAY';
      next if !@{$eqArray};
      foreach my $entry (@{$eqArray}) {
        croak("eqs: subentry contains a non-scalar") if ref($entry);
        croak("eqs: subentry undefined")             if !defined($entry);
        croak("eqs: '$entry': unknown element")      if !exists($elem_ids->{$entry});
        croak("eqs: '$entry': duplicate element")    if exists($seen{$entry});
        $seen{$entry} = undef;
      }
      next if @{$eqArray} == 1;
      my @tmp = @{$eqArray};
      my @eqArray;
      $eqIds{$tabElems->{shift(@tmp)}} = \@eqArray;
      foreach my $e (@tmp) {
        push(@eqArray, delete $tabElems->{$e});
      }
    }
    $eqIds = \%eqIds;
  }
  @{$self}{qw(elems elem_ids tab_elems eq_ids)} = ($elems, $elem_ids, $tabElems, $eqIds);
  return bless($self, $class);
}


#
# $self->$_reset()  - set (matrix elems elem_ids tab_elems eq_ids) to
#                     empty structures
# $self->$_reset(1) - set (matrix elems elem_ids tab_elems eq_ids) to
#                     undef
my $_reset = sub {
  @{$_[0]}{qw(matrix elems elem_ids tab_elems eq_ids)} =
    $_[1] ? ( {},    [],   {},      {},       {})  : ((undef) x 5);
};


# just a function, not a method.
sub _rule_pos_array_f {
  my ($str) = @_;
  my @rule_pos;
  my $idx = index($str, '|');
  while($idx != -1) {
    push(@rule_pos, $idx);
    $idx = index($str, '|', $idx + 1);
  }
  return \@rule_pos;
}

# just a function, not a method.
sub _int_array_cmp {
  my ($arr1, $arr2) = @_;
  return !1 if @$arr1 != @$arr2;
  for (my $i = 0; $i < @$arr1; ++$i) {
    return !1 if $arr1->[$i] != $arr2->[$i];
  }
  return 1;
}

# just a function, not a method.
sub _parse_header_f {
  my ($header, $pedantic) = @_;
  $header =~ s/\s+$//;
  my @rule_pos;
  if ($pedantic) {
    substr($header, -1, 1) eq '|' or croak("'$header': Wrong header format");
  }
  $header =~ s/^\s*\|.*?\|\s*// or croak("'$header': Wrong header format");
  my @elem_array = $header eq "|" ? ('') : split(/\s*\|\s*/, $header);
  return ([], {}) if $header eq "";
  my $index = 0;
  my %elem_ids;
  foreach my $name (@elem_array) {
    croak("'$name': duplicate name in header") if exists($elem_ids{$name});
    $elem_ids{$name} = $index++;
  }
  return (\@elem_array, \%elem_ids);
}


my $_parse_row = sub {
  my $self = shift;
  my $row = shift;
  my ($inc, $noinc) = @{$self}{qw(inc noinc)};
  $row =~ s/^\|\s*([^|]*?)\s*\|\s*// or croak("Wrong row format: '$row'");
  my $rowElem = $1;
  my @rowContents;
  if ($row ne "") {
    $row =~ s/\s*\|\s*$//;
    my @entries = $row eq "" ? ("") : split(/\s*\|\s*/, $row, -1);
    foreach my $entry (@entries) {
      if ($entry eq $inc) {
        push(@rowContents, 1);
      } elsif ($entry eq $noinc) {
        push(@rowContents, "");
      } else {
        croak("'$entry': unexpected entry");
      }
    }
  }
  return ($rowElem, \@rowContents);
};


my $_parse_table = sub {
  my $self = shift;
  my ($lines, $allow_subset, $pedantic) = @_;
  my $index = 0;
  for (; $index < @$lines; ++$index) { # skip heading empty lines
    last if $lines->[$index] =~ /\S/;
  }
  if ($index == @$lines) {
    $self->$_reset(1);
    return;
  }
  my ($h_elems, $h_ids) = _parse_header_f($lines->[$index], $pedantic);
  my ($sep_line, $rule_pos);
  if ($pedantic) {
    ($sep_line = $lines->[$index]) =~ s/\s+$//;
    $rule_pos = _rule_pos_array_f($sep_line);
    for (my $i = 0; $i < @$rule_pos - 1; ++$i) {
      my ($b, $e) = @{$rule_pos}[$i, $i + 1];
      substr($sep_line, $b, 1, '+') if $i;
      my $d = $e - $b;
      next unless $d > 1;
      --$d;
      substr($sep_line, $b + 1, $d, '-' x $d);
    }
  }
  my $elem_ids;
  my %rows;
  my @rowElems;                 # To keep oder of additional row elements, if any.
  for (++$index; $index < @$lines; ++$index) {
    (my $line = $lines->[$index]) =~ s/\s+$//;
    last if $line eq q{};
    if ($pedantic) {
      $line =~ /\S/;
      $-[0] == $rule_pos->[0] or croak("Wrong indentation at line " . ($index + 1));
    }
    if ($line =~ /^\s*\|-/) {
      if ($pedantic) {
        $line eq $sep_line or croak("Invalid row separator at line " . ($index + 1));
      }
      next;
    }
    if ($pedantic) {
      _int_array_cmp(_rule_pos_array_f($line), $rule_pos) or
        croak("Wrong row format at line " . ($index + 1));
    }
    $line =~ s/^\s*//;
    my ($rowElem, $rowContent) = $self->$_parse_row($line);
    croak("'$rowElem': duplicate element in first column") if exists($rows{$rowElem});
    $rows{$rowElem} = $rowContent;
    push(@rowElems, $rowElem);
  }
  if ($self->{prespec}) {
    my $tab_elems = $self->{tab_elems};
    $elem_ids     = $self->{elem_ids};
    foreach my $elem (keys(%{$h_ids})) {
      croak("'$elem': unknown element in table") if !exists($tab_elems->{$elem});
    }
    foreach my $elem (keys(%rows)) {
      croak("'$elem': unknown element in table") if !exists($tab_elems->{$elem});
    }
    if (!$allow_subset) {
      foreach my $elem (keys(%{$tab_elems})) {
        croak("'$elem': column missing for element") if !exists($h_ids->{$elem});
        croak("'$elem': row missing for element"   ) if !exists($rows{$elem});
      }
    }
  } else {
    if ($allow_subset) {
      foreach my $rowElem (@rowElems) {
        if (!exists($h_ids->{$rowElem})) {
          $h_ids->{$rowElem} = @{$h_elems};
          push(@{$h_elems}, $rowElem);
        }
      }
    } else {
      croak("Number of elements in header does not match number of elemens in row")
        if keys(%{$h_ids}) != keys(%rows);
      foreach my $elem (keys(%{$h_ids})) {
        croak("'$elem': row missing for element") if !exists($rows{$elem});
      }
    }
    my %tmp = %{$h_ids};
    @{$self}{qw(elems elem_ids tab_elems eq_ids)} = ($h_elems, $h_ids, \%tmp, {});
    $elem_ids = $h_ids;
  }
  my $eq_ids = $self->{eq_ids};
  my %matrix;
  while (my ($rowElem, $rowContents) = each(%rows)) {
    my %new_row;
    for (my $i = 0; $i < @{$rowContents}; $i++) {
      if ($rowContents->[$i]) {
        my $e_id = $elem_ids->{$h_elems->[$i]};
        $new_row{$e_id} = undef;
        if (exists($eq_ids->{$e_id})) {
          foreach my $eq_id (@{$eq_ids->{$e_id}}) {
            $new_row{$eq_id} = undef
          }
        }
      }
    }
    if (%new_row) {
      $matrix{$elem_ids->{$rowElem}} = \%new_row;
      if (exists($eq_ids->{$rowElem})) {
        foreach my $eq_id (@{$eq_ids->{$rowElem}}) {
          $matrix{$eq_id} = {%new_row};
        }
      }
    }
  }
  $self->{matrix} = \%matrix;
  return;
};


sub get {
  my $self = shift;
  croak("Odd number of arguments") if @_ % 2;
  my %args = @_;
  my $allow_subset = delete $args{allow_subset};
  my $pedantic     = delete $args{pedantic};
  croak("Missing argument 'src'") if !@_;
  my $src          = delete $args{src}          // croak("Invalid value argument for 'src'");
  croak(join(", ", sort(keys(%args))) . ": unexpected argument") if %args;
  my $inputArray;
  if (ref($src)) {
    croak("Invalid value argument for 'src'") if ref($src) ne 'ARRAY';
    foreach my $e (@{$src}) {
      croak("src: each entry must be a defined scalar") if (ref($e) || !defined($e));
    }
    $inputArray = $src;
  } elsif ($src !~ /\n/) {
    open(my $h, '<', $src);
    $inputArray = [<$h>];
    close($h);
  } else {
    $inputArray = [split(/\n/, $src)];
  }
  $self->$_reset() if !$self->{prespec};
  $self->$_parse_table($inputArray, $allow_subset, $pedantic);
  return wantarray ? @{$self}{qw(matrix elems elem_ids)} : $self;
}


sub inc         {croak("Unexpected argument(s)") if @_ > 1; $_[0]->{inc};}
sub noinc       {croak("Unexpected argument(s)") if @_ > 1; $_[0]->{noinc};}
sub prespec     {croak("Unexpected argument(s)") if @_ > 1; $_[0]->{prespec};}
sub elems       {croak("Unexpected argument(s)") if @_ > 1; $_[0]->{elems};}
sub elem_ids    {croak("Unexpected argument(s)") if @_ > 1; $_[0]->{elem_ids};}
sub tab_elems   {croak("Unexpected argument(s)") if @_ > 1; $_[0]->{tab_elems};}
sub eq_ids      {croak("Unexpected argument(s)") if @_ > 1; $_[0]->{eq_ids};}


sub matrix {
  my $self = shift;
  croak("Odd number of arguments") if @_ % 2;
  my %args = @_;
  my $bless = delete $args{bless};
  croak("Unexpected argument(s)") if %args;
  return if !$self->{matrix};
  bless($self->{matrix}, "Text::Table::Read::RelationOn::Tiny::_Relation_Matrix") if $bless;
  return $self->{matrix};
}


sub matrix_named {
  my $self = shift;
  croak("Odd number of arguments") if @_ % 2;
  my %args = @_;
  my $bless = delete $args{bless};
  croak("Unexpected argument(s)") if %args;

  my ($matrix, $elems) = @{$self}{qw(matrix elems)};
  return if !$matrix;
  my $matrix_named = {};
  bless($matrix_named, "Text::Table::Read::RelationOn::Tiny::_Relation_Matrix") if $bless;
  while (my ($rowElemIdx, $rowContents) = each(%{$matrix})) {
    $matrix_named->{$elems->[$rowElemIdx]} = {map {$elems->[$_] => undef} keys(%{$rowContents})};
  }
  return $matrix_named;
}



{
  package Text::Table::Read::RelationOn::Tiny::_Relation_Matrix;

  sub related { return exists($_[0]->{$_[1]}) && exists($_[0]->{$_[1]}->{$_[2]}); }
}


1; # End of Text::Table::Read::RelationOn::Tiny



__END__