File Coverage

blib/lib/Data/Table.pm

Criterion	Covered	Total	%
statement	1499	1721	87.1
branch	609	1040	58.5
condition	129	263	49.0
subroutine	102	110	92.7
pod	68	81	83.9
total	2407	3215	74.8

package Data::Table;
BEGIN { die "Your perl version is old, see README for instructions" if $] < 5.005; }

use strict;
use vars qw($VERSION %DEFAULTS);
use Carp;
#use Data::Dumper;

$VERSION = '1.76';
%DEFAULTS = (
  "CSV_DELIMITER"=>',', # controls how to read/write CSV file
  "CSV_QUALIFIER"=>'"',
  "OS"=>0,
  # operatoring system: 0 for UNIX (\n as linebreak), 1 for Windows
  # (\r\n as linebreak), 2 for MAC  (\r as linebreak)
  # this controls how to read and write CSV/TSV file
  "ENCODING"=>'UTF-8'
  # default encoding for fromFile, fromCSV, fromTSV
);
%Data::Table::TSV_ESC = ( '0'=>"\0", 'n'=>"\n", 't'=>"\t", 'r'=>"\r", 'b'=>"\b",
              "'"=>"'", '"'=>"\"", '\\'=>"\\" );
%Data::Table::TSV_ENC = ( "\0"=>'0', "\n"=>'n', "\t"=>'t', "\r"=>'r', "\b"=>'b',
              "'"=>"'", "\""=>'"', "\\"=>'\\' );
use constant ROW_BASED => 0;
use constant COL_BASED => 1;
use constant NUMBER => 0;
use constant STRING => 1;
use constant ASC => 0;
use constant DESC => 1;
use constant INNER_JOIN => 0;
use constant LEFT_JOIN => 1;
use constant RIGHT_JOIN => 2;
use constant FULL_JOIN => 3;
use constant OS_UNIX => 0;
use constant OS_PC => 1;
use constant OS_MAC => 2;

sub new {
  my ($pkg, $data, $header, $type, $enforceCheck) = @_;
  my $class = ref($pkg) || $pkg;
  $type = 0 unless defined($type);
  $header=[] unless defined($header);
  $data=[] unless defined($data);
  $enforceCheck = 1 unless defined($enforceCheck);
  confess "new Data::Table: Size of data does not match header\n"
    if (($type && (scalar @$data) && $#{$data} != $#{$header}) ||
        (!$type && (scalar @$data) && $#{$data->[0]} != $#{$header}));
  my $colHash = checkHeader($header);
  if ($enforceCheck && scalar @$data > 0) {
    my $size=scalar @{$data->[0]};
    for (my $j =1; $j
      confess "Inconsistent array size at data[$j]" unless (scalar @{$data->[$j]} == $size);
    }
  } elsif (scalar @$data == 0) {
    $type = 0;
  }
  my $self={ data=>$data, header=>$header, type=>$type, colHash=>$colHash, OK=>[], MATCH=>[]};
  return bless $self, $class;
}

sub checkHeader {
  my $header = shift;
  my $colHash = {};
  for (my $i = 0; $i < scalar @$header; $i++) {
    my $elm = $header->[$i];
    #warn "Column name: $elm at column ".($i+1)." is an integer, using an integer column name will mask the corresponding column index!" if ($elm =~ /^\d+$/);
    confess "Undefined column name (empty or all space) at column ".($i+1) unless $elm;
    #confess "Header name ".$colHash->{$elm}." appears more than once" if defined($colHash->{$elm});
    if (defined($colHash->{$elm})) {
      confess "Header name ($elm) appears more than once: in column ".($colHash->{$elm}+1)." and column ".($i+1).".";
    }
    $colHash->{$elm} = $i;
  }
  return $colHash;
}

# translate a column name into its position in the header
# (also in column-based table)
sub colIndex {
  my ($self, $colID) = @_;
  return $self->{colHash}->{$colID} if exists $self->{colHash}->{$colID};
  return $colID if $colID =~ /^\d+$/;
  return -1;
  #if ($colID =~ /\D/) {
  #  my $i = $self->{colHash}->{$colID};
  #  return -1 unless defined($i);
  #  return $i;
  #}
  #return $colID; # assume an index already
}

sub hasCol {
  my ($self, $col) = @_;
  return $self->colIndex($col) >= 0;
}

sub nofCol {
  my $self = shift;
  return scalar @{$self->{header}};
}

sub isEmpty {
  my $self  = shift;
  return $self->nofCol == 0;
}

sub nofRow {
  my $self = shift;
  return 0 if (scalar @{$self->{data}} == 0);
  return ($self->{type})?
    scalar @{$self->{data}->[0]} : scalar @{$self->{data}};
}

sub lastRow {
  my $self = shift;
  return $self->nofRow - 1;
}

sub lastCol {
  my $self = shift;
  return $self->nofCol - 1;
}

sub colName {
  my ($self, $colNumericIndex) = @_;
  return ($self->header())[$colNumericIndex];
}

sub iterator {
  my ($self, $arg_ref) = @_;
  my %arg = defined $arg_ref ? %$arg_ref : ();
  $arg{reverse} = 0 unless exists $arg{reverse};
  my $current_row = $arg{reverse} ? $self->lastRow : 0;

  return sub {
    my $rowIdx = shift;
    if (defined $rowIdx) { # return row index for previously returned record
      my $prevRow = $arg{reverse} ? $current_row+1 : $current_row-1;
      return ($prevRow<0 or $prevRow > $self->nofRow-1)? undef: $prevRow;
    }
    return undef if $current_row < 0 or $current_row > $self->nofRow - 1;
    my $oldRow = $current_row;
    $arg{reverse} ? $current_row-- : $current_row++;
    return $self->rowHashRef($oldRow);
  }
}

# still need to consider quotes and comma in string
# need to get csv specification
sub csvEscape {
  my ($s, $arg_ref) = @_;
  my ($delimiter, $qualifier) = ($Data::Table::DEFAULTS{CSV_DELIMITER}, $Data::Table::DEFAULTS{CSV_QUALIFIER});
  $delimiter = $arg_ref->{'delimiter'} if (defined($arg_ref) && defined($arg_ref->{'delimiter'}));
  $qualifier = $arg_ref->{'qualifier'} if (defined($arg_ref) && defined($arg_ref->{'qualifier'}));
  return '' unless defined($s);
  my $qualifier2 = $qualifier;
  $qualifier2 = substr($qualifier, 1, 1) if length($qualifier)>1; # in case qualifier is a special symbol for regular expression
  $s =~ s/$qualifier/$qualifier2$qualifier2/g;
  if ($s =~ /[$qualifier$delimiter\r\n]/) { return "$qualifier2$s$qualifier2"; }
  return $s;
}

sub tsvEscape {
  my $s = shift;
  #my %ESC = ( "\0"=>'0', "\n"=>'n', "\t"=>'t', "\r"=>'r', "\b"=>'b',
  #            "'"=>"'", "\""=>'"', "\\"=>'\\' );
  ## what about \f? MySQL treats \f as f.
  return "\\N" unless defined($s);
  $s =~ s/([\0\\\b\r\n\t"'])/\\$Data::Table::TSV_ENC{$1}/g;
  return $s;
}

# output table in CSV format
sub csv {
  my ($self, $header, $arg_ref)=@_;
  my ($status, @t);
  my $s = '';
  my ($OS, $fileName_or_handler) = ($Data::Table::DEFAULTS{OS}, undef);
  $OS = $arg_ref->{'OS'} if (defined($arg_ref) && defined($arg_ref->{'OS'}));
  my ($delimiter, $qualifier) = ($Data::Table::DEFAULTS{CSV_DELIMITER}, $Data::Table::DEFAULTS{CSV_QUALIFIER});
  if (defined($arg_ref)) {
    $delimiter = $arg_ref->{'delimiter'} if defined($arg_ref->{'delimiter'});
    $qualifier = $arg_ref->{'qualifier'} if defined($arg_ref->{'qualifier'});
    $fileName_or_handler = $arg_ref->{'file'} if defined($arg_ref->{'file'});
  }
  my $delimiter2 = $delimiter; $delimiter2 = substr($delimiter, 1, 1) if length($delimiter)>1;
  my $endl = ($OS==2)?"\r":(($OS==1)?"\r\n":"\n");
  $header=1 unless defined($header);
  $s=join($delimiter2, map {csvEscape($_, {delimiter=>$delimiter, qualifier=>$qualifier})} @{$self->{header}}) . $endl if $header;
######  $self->rotate if $self->{type};
  if ($self->{data}) {
    $self->rotate() if ($self->{type});
    my $data=$self->{data};
    for (my $i=0; $i<=$#{$data}; $i++) {
      $s .= join($delimiter2, map {csvEscape($_, {delimiter=>$delimiter, qualifier=>$qualifier})} @{$data->[$i]}) . $endl;
    }
  }
  if (defined($fileName_or_handler)) {
    my $OUT;
    my $isFileHandler = ref($fileName_or_handler) ne '';
    if ($isFileHandler) {
      $OUT = $fileName_or_handler;
    } else {
      open($OUT, "> $fileName_or_handler") or confess "Cannot open $fileName_or_handler to write.\n";
      binmode $OUT;
    }
    print $OUT $s;
    close($OUT) unless $isFileHandler;
  }
  return $s;
}

# output table in TSV format
sub tsv {
  my ($self, $header, $arg_ref)=@_;
  my ($status, @t);
  my $s = '';
  my ($OS, $fileName_or_handler, $transform_element) = ($Data::Table::DEFAULTS{OS}, undef, 1);
  if (defined($arg_ref)) {
    $OS = $arg_ref->{'OS'} if (defined($arg_ref->{'OS'}));
    $fileName_or_handler = $arg_ref->{'file'} if (defined($arg_ref->{'file'}));
    $transform_element = $arg_ref->{'transform_element'} if (defined($arg_ref->{'transform_element'}));
  }
  my $endl = ($OS==2)?"\r":(($OS==1)?"\r\n":"\n");
  $header=1 unless defined($header);
  if ($header) {
    if ($transform_element) {
      $s=join("\t", map {tsvEscape($_)} @{$self->{header}}) . $endl;
    } else {
      $s=join("\t",@{$self->{header}}) . $endl;
    }
  }
######  $self->rotate if $self->{type};
  if ($self->{data}) {
    $self->rotate() if ($self->{type});
    my $data=$self->{data};
    for (my $i=0; $i<=$#{$data}; $i++) {
      if ($transform_element) {
        $s .= join("\t", map {tsvEscape($_)} @{$data->[$i]}) . $endl;
      } else {
        $s .= join("\t", @{$data->[$i]}) . $endl;
      }
    }
  }
  if (defined($fileName_or_handler)) {
    my $OUT;
    my $isFileHandler = ref($fileName_or_handler) ne '';
    if ($isFileHandler) {
      $OUT = $fileName_or_handler;
    } else {
      open($OUT, "> $fileName_or_handler") or confess "Cannot open $fileName_or_handler to write.\n";
      binmode $OUT;
    }
    print $OUT $s;
    close($OUT) unless $isFileHandler;;
  }
  return $s;
}

# output table in HTML format
sub html {
  my ($self, $colorArrayRef_or_classHashRef, $tag_tbl, $tag_tr, $tag_th, $tag_td, $portrait, $callback) = @_;
  my ($s, $s_tr, $s_td, $s_th) = ("", "tr", "", "th");
  my $key;
  $tag_tbl = { class => "data_table" } unless (ref $tag_tbl eq 'HASH');
  $tag_tr = {} unless (ref $tag_tr eq 'HASH');
  $tag_th = {} unless (ref $tag_th eq 'HASH');
  $tag_td = {} unless (ref $tag_td eq 'HASH');
  $portrait = 1 unless defined($portrait);
  my $cb=0;
  if (defined($callback)) {
    confess "wiki: Expecting subroutine for callback parameter!" if ref($callback) ne 'CODE';
    $cb=1;
  }

  my $tag2str = sub {
    my $tag = shift;
    my $s="";
    foreach my $key (keys %$tag) {
      next unless $tag->{$key};
      if ($key eq '') {
        $s .=" ".$tag->{$key};
        #for backward compatibility, in case the tag is a str
        # '' => 'align="right" valign="bottom"'
      } else {
        $s .= " $key=\"$tag->{$key}\"";
      }
    }
    return $s;
  };

  $s = "($tag_tbl).">\n";
  my $header=$self->{header};
  my $l_colorByClass = 0;
  my @BG_COLOR=("#D4D4BF","#ECECE4","#CCCC99");
  my @CELL_CLASSES=("data_table_odd","data_table_even","data_table_header");
  if (ref($colorArrayRef_or_classHashRef) eq "HASH") {
    $l_colorByClass = 1;
    $CELL_CLASSES[1]=$colorArrayRef_or_classHashRef->{even} if defined($colorArrayRef_or_classHashRef->{even});
    $CELL_CLASSES[0]=$colorArrayRef_or_classHashRef->{odd} if defined($colorArrayRef_or_classHashRef->{odd});
    $CELL_CLASSES[2]=$colorArrayRef_or_classHashRef->{header} if defined($colorArrayRef_or_classHashRef->{header});
  } elsif ((ref($colorArrayRef_or_classHashRef) eq "ARRAY") && (scalar @$colorArrayRef_or_classHashRef==3)) {
    @BG_COLOR=@$colorArrayRef_or_classHashRef;
  }

  $s_tr = $tag2str->($tag_tr);
  $s_th = $tag2str->($tag_th);

  if ($portrait) {
    $s .= "
    my $clr="";
    if ($l_colorByClass) {
      $clr=" class=\"".$CELL_CLASSES[2]."\"" if ($CELL_CLASSES[2]);
    } else {
      $clr=" style=\"background-color:".$BG_COLOR[2].";\"" if ($BG_COLOR[2]);
    }
    $s .= "\n";
    for (my $i=0; $i<=$#{$header}; $i++) {
      $s .="($callback->({%$tag_th}, -1, $i, $header->[$i], $self)) : $s_th) .">".$header->[$i]."\n";
    }
    $s .="
    $s .= "
    $self->rotate() if $self->{type};
    my $data=$self->{data};
    $s .= "
    for (my $i=0; $i<=$#{$data}; $i++) {
      $clr="";
      if ($l_colorByClass) {
        $clr=" class=\"".$CELL_CLASSES[$i%2]."\"" if ($CELL_CLASSES[$i%2]);
      } else {
        $clr=" style=\"background-color:".$BG_COLOR[$i%2].";\"" if ($BG_COLOR[$i%2]);
      }
      $s .= "\n";
      for (my $j=0; $j<=$#{$header}; $j++) {
        my $td = $tag_td->{$j} || $tag_td->{$header->[$j]} || {};
        my $s_td=$tag2str->($cb ? $callback->({%$td}, $i, $j, $header->[$j], $self) : $td) || "";
        $s .= ($s_td)? "":"
        $s .= (defined($data->[$i][$j]) && $data->[$i][$j] ne '')?$data->[$i][$j]:" ";
        $s .= "
      }
      $s .= "
    }
    $s .= "
  } else {
    $self->rotate() unless $self->{type};
    my $tag_th_def={};
    if ($l_colorByClass) {
      $tag_th_def->{"class"}=$CELL_CLASSES[2] if $CELL_CLASSES[2];
    } else {
      $tag_th_def->{"style"}="background-color:".$BG_COLOR[2].";" if $BG_COLOR[2];
    }
    my $merge_tag = sub {
      my ($old, $usr)=@_;
      foreach my $k(keys %$usr) {
        if (exists $old->{$k}) {
          if (!defined($usr->{k}) or $usr->{k} eq '') {
            undef $old->{k};
          } elsif ($k eq 'style' and (index($usr->{k}, 'background-color:')!=-1)) {
            $old->{$k}=$usr->{$k};
          } else {
            $old->{$k}.= " "+$usr->{$k};
          }
        } else {
          $old->{$k}=$usr->{$k} if $usr->{$k};
        }
      }
    };
    $merge_tag->($tag_th_def, $tag_th) if defined($tag_th);
    $s_th=$tag2str->($tag_th_def);

    my $data=$self->{data};
    $s .="
    for (my $i = 0; $i <= $#{$header}; $i++) {
      $s .= "
      $s .= "($callback->({%$tag_th_def}, -1, $i, $header->[$i], $self)) : $s_th) .">". $header->[$i] . "
      my $td_def = $tag_td->{$i} || $tag_td->{$header->[$i]} || {};
      $td_def = {'' => $td_def} unless ref $td_def;
      for (my $j=0; $j<=$#{$data->[0]}; $j++) {
        my $td = {};
        if ($l_colorByClass) {
          $td->{"class"}=$CELL_CLASSES[$j%2] if $CELL_CLASSES[$j%2];
        } else {
          $td->{"style"}="background-color:".$BG_COLOR[$j%2].";" if $BG_COLOR[$j%2];
        }
        $merge_tag->($td, $td_def);
        my $s_td=$tag2str->($cb ? $callback->({%$td}, $j, $i, $header->[$i], $self) : $td) || "";
        $s .= ($s_td)? "":"
        $s .= (defined($data->[$i][$j]) && $data->[$i][$j] ne '')?$data->[$i][$j]:' ';
        $s .= "
      }
      $s .= "
    }
    $s .="
  }
  $s .= "