File Coverage

blib/lib/Text/ANSITable/SQLStyleSheet.pm

Criterion	Covered	Total	%
statement	92	99	92.9
branch	19	28	67.8
condition	1	3	33.3
subroutine	15	15	100.0
pod	1	1	100.0
total	128	146	87.6

package Text::ANSITable::SQLStyleSheet;
use 5.018000;
use strict;
use warnings;
use version;
use Text::ANSITable;
use JSON;
use DBI;
use DBD::SQLite;

our $VERSION = '0.05';

our $Json = JSON->new;

sub _sqlite_type_from_sth_ix {

  my ($dbh, $sth, $ix) = @_;

  my $sth_type = $sth->{TYPE}[ $ix ];

  # NOTE: It seems that as of 2018-10-06 DBD::SQLite returns the
  # wrong kind of value for TYPE. It also does not implement the
  # type_info method.
  #
  # Worse, for something like `SELECT 1, TYPEOF(1)` SQLite itself
  # considers the first to be an `integer`, but DBD::SQLite returns
  # `VARCHAR` in $sth->{TYPE}.
  #
  # Reported in .
  #
  # Other drivers may have similar issues, so this is best-effort
  # guesswork.
  #
  # SQLite will do further guesswork on the type we pass to it, per
  # .

  if (defined $sth_type) {

    my $type_info = $dbh->type_info($sth_type);

    if ( $type_info and exists $type_info->{TYPE_NAME} ) {

      return $type_info->{TYPE_NAME};

    } elsif ($sth_type !~ /^\d+$/) {

      return $sth_type;

    }

  }

  return 'TEXT';

}

sub _from_sth_sql {

  my ($class, $sth, $sql_or_code) = @_;

  my $dbh = DBI->connect('dbi:SQLite:dbname=:memory:');

  local $dbh->{sqlite_allow_multiple_statements} = 1;

  $dbh->do(q{
    PRAGMA synchronous  = OFF;
    PRAGMA journal_mode = OFF;
    PRAGMA locking_mode = EXCLUSIVE;
  });

  my $fields = join(',', map {
    sprintf(
      'CAST(NULL AS %s) AS %s',
      _sqlite_type_from_sth_ix($dbh, $sth, $_),
      $dbh->quote_identifier(undef, undef, $sth->{NAME}[$_]))
  } 0 .. @{ $sth->{NAME} } - 1);

  my $create_sth = $dbh->prepare(sprintf(q{
    CREATE TABLE data AS SELECT %s LIMIT 0
  }, $fields));

  $create_sth->execute();

  my $insert_sth = $dbh->prepare(sprintf(q{
    INSERT INTO data VALUES(%s)
  }, join(',', map { '?' } 0 .. @{ $sth->{NAME} } - 1)));

  $dbh->begin_work;

  while (my $row = $sth->fetchrow_arrayref()) {
    $insert_sth->execute(@$row);
  }

  $dbh->commit;

#  $dbh->sqlite_backup_to_file('DEBUG.sqlite');

  if ( 'CODE' eq ref( $sql_or_code ) ) {

    return $class->from_sth( $sql_or_code->($dbh) );

  } else {

    my $final_sth = $dbh->prepare( $sql_or_code );
    $final_sth->execute();
    return $class->from_sth( $final_sth );

  }

}

sub from_sth {

  my ($class, $sth, $sql_or_code) = @_;

  return _from_sth_sql(@_) if defined $sql_or_code;

  my %col2ix;
  $col2ix{$_} = keys %col2ix
    for @{ $sth->{NAME} };

  # filter out __*_style columns
  my @wanted = sort { $a <=> $b } map {
    /^__(\w+)_style$/ ? () : $col2ix{$_}
  } keys %col2ix;

  my $t = Text::ANSITable->new;

  $t->columns([ map { $sth->{NAME}[$_] } @wanted ]);

  my $nth = 0;

  while (my $row = $sth->fetchrow_arrayref) {

    $t->add_row([ @{ $row }[ @wanted ] ]);

    if ( $nth == 0 ) {
      _column_style( $t, $row, \%col2ix, $col2ix{__column_style} );
    }

    _row_style( $t, $nth, $row, \%col2ix, $col2ix{__row_style} );
    _cell_styles( $t, $nth, $row, \%col2ix, $col2ix{__cell_style} );

    $nth += 1;

  }

  return $t;

}

sub _get_hashref {
  my ($row, $ix) = @_;

  return unless defined $ix;
  return unless defined $row->[ $ix ];

  my $h = $Json->decode( $row->[ $ix ] );

  return unless 'HASH' eq ref( $h );

  delete @$h{ grep !defined($h->{$_}), keys %$h };

  return $h;

}

sub _column_style {

  my ($t, $row, $col2ix, $ix) = @_;

  return unless my $style = _get_hashref( $row, $ix );

  for my $column ( grep { exists $col2ix->{$_} } keys %$style ) {
    $t->set_column_style( $column, %{ $style->{ $column } } );
  }

}

sub _row_style {

  my ($t, $nth_row, $row, $col2ix, $ix) = @_;

  return unless my $style = _get_hashref( $row, $ix );

  $t->set_row_style( $nth_row, %$style );

}

sub _cell_styles {

  my ($t, $nth_row, $row, $col2ix, $ix) = @_;

  return unless my $style = _get_hashref( $row, $ix );

  for my $column ( grep { exists $col2ix->{$_} } keys %$style ) {

    my %cell_style = %{ $style->{ $column } };

    # override cell contents if pseudo-style `text` is specified
    if ( exists $cell_style{value} ) {
      $t->set_cell( $nth_row, $column, $cell_style{value} );
      delete $cell_style{value};
    }

    $t->set_cell_style(
      $nth_row,
      $column,
      %cell_style
    );

  }

}

1;

__END__