File Coverage

blib/lib/DBD/SQLeet/VirtualTable/PerlData.pm

Criterion	Covered	Total	%
statement	106	126	84.1
branch	33	50	66.0
condition	9	11	81.8
subroutine	22	24	91.6
pod	4	4	100.0
total	174	215	80.9

#======================================================================
package DBD::SQLeet::VirtualTable::PerlData;
#======================================================================
use strict;
use warnings;
use base 'DBD::SQLeet::VirtualTable';
use DBD::SQLeet;
use constant SQLITE_3010000 => $DBD::SQLeet::sqlite_version_number >= 3010000 ? 1 : 0;
use constant SQLITE_3021000 => $DBD::SQLeet::sqlite_version_number >= 3021000 ? 1 : 0;

# private data for translating comparison operators from Sqlite to Perl
my $TXT = 0;
my $NUM = 1;
my %SQLOP2PERLOP = (
#              TXT     NUM
  '='     => [ 'eq',   '==' ],
  '<'     => [ 'lt',   '<'  ],
  '<='    => [ 'le',   '<=' ],
  '>'     => [ 'gt',   '>'  ],
  '>='    => [ 'ge',   '>=' ],
  'MATCH' => [ '=~',   '=~' ],
  (SQLITE_3010000 ? (
  'LIKE'  => [ 'DBD::SQLeet::strlike', 'DBD::SQLeet::strlike' ],
  'GLOB'  => [ 'DBD::SQLeet::strglob', 'DBD::SQLeet::strglob' ],
  'REGEXP'=> [ '=~',   '=~' ],
  ) : ()),
  (SQLITE_3021000 ? (
  'NE'    => [ 'ne',   '!=' ],
  'ISNOT' => [ 'defined',   'defined' ],
  'ISNOTNULL' => [ 'defined',   'defined' ],
  'ISNULL'    => [ '!defined',  '!defined' ],
  'IS'    => [ '!defined',   '!defined' ],
  ) : ()),
);

#----------------------------------------------------------------------
# instanciation methods
#----------------------------------------------------------------------

sub NEW {
  my $class = shift;
  my $self  = $class->_PREPARE_SELF(@_);

  # verifications
  my $n_cols = @{$self->{columns}};
  $n_cols > 0
    or die "$class: no declared columns";
  !$self->{options}{colref} || $n_cols == 1
    or die "$class: must have exactly 1 column when using 'colref'";
  my $symbolic_ref = $self->{options}{arrayrefs}
                  || $self->{options}{hashrefs}
                  || $self->{options}{colref}
    or die "$class: missing option 'arrayrefs' or 'hashrefs' or 'colref'";

  # bind to the Perl variable
  no strict "refs";
  defined ${$symbolic_ref}
    or die "$class: can't find global variable \$$symbolic_ref";
  $self->{rows} = \ ${$symbolic_ref};

  bless $self, $class;
}

sub _build_headers_optypes {
  my $self = shift;

  my $cols = $self->sqlite_table_info;

  # headers : names of columns, without type information
  $self->{headers} = [ map {$_->{name}} @$cols ];

  # optypes : either $NUM or $TEXT for each column
  # (applying  algorithm from datatype3.html" for type affinity)
  $self->{optypes}
    = [ map {$_->{type} =~ /INT|REAL|FLOA|DOUB/i ? $NUM : $TXT} @$cols ];
}

#----------------------------------------------------------------------
# method for initiating a search
#----------------------------------------------------------------------

sub BEST_INDEX {
  my ($self, $constraints, $order_by) = @_;

  $self->_build_headers_optypes if !$self->{headers};

  # for each constraint, build a Perl code fragment. Those will be gathered
  # in FILTER() for deciding which rows match the constraints.
  my @conditions;
  my $ix = 0;
  foreach my $constraint (grep {$_->{usable}} @$constraints) {
    my $col = $constraint->{col};
    my ($member, $optype);

    # build a Perl code fragment. Those fragments will be gathered
    # and eval-ed in FILTER(), for deciding which rows match the constraints.
    if ($col == -1) {
      # constraint on rowid
      $member = '$i';
      $optype = $NUM;
    }
    else {
      # constraint on regular column
      my $opts = $self->{options};
      $member  = $opts->{arrayrefs} ? "\$row->[$col]"
               : $opts->{hashrefs}  ? "\$row->{$self->{headers}[$col]}"
               : $opts->{colref}    ? "\$row"
               :                      die "corrupted data in ->{options}";
      $optype  = $self->{optypes}[$col];
    }
    my $op = $SQLOP2PERLOP{$constraint->{op}}[$optype];
    if (SQLITE_3021000 && $op =~ /defined/) {
      if ($constraint->{op} =~ /NULL/) {
        push @conditions,
          "($op($member))";
      } else {
        push @conditions,
          "($op($member) && !defined(\$vals[$ix]))";
      }
    } elsif (SQLITE_3010000 && $op =~ /str/) {
      push @conditions,
        "(defined($member) && defined(\$vals[$ix]) && !$op(\$vals[$ix], $member))";
    } else {
      push @conditions,
        "(defined($member) && defined(\$vals[$ix]) && $member $op \$vals[$ix])";
    }
    # Note : $vals[$ix] refers to an array of values passed to the
    # FILTER method (see below); so the eval-ed perl code will be a
    # closure on those values
    # info passed back to the SQLite core -- see vtab.html in sqlite doc
    $constraint->{argvIndex} = $ix++;
    $constraint->{omit}      = 1;
  }

  # further info for the SQLite core
  my $outputs = {
    idxNum           => 1,
    idxStr           => (join(" && ", @conditions) || "1"),
    orderByConsumed  => 0,
    estimatedCost    => 1.0,
    estimatedRows    => undef,
  };

  return $outputs;
}


#----------------------------------------------------------------------
# methods for data update
#----------------------------------------------------------------------

sub _build_new_row {
  my ($self, $values) = @_;

  my $opts = $self->{options};
  return $opts->{arrayrefs} ? $values
       : $opts->{hashrefs}  ? { map {$self->{headers}->[$_], $values->[$_]}
                                    (0 .. @{$self->{headers}} - 1) }
       : $opts->{colref}    ? $values->[0]
       :                      die "corrupted data in ->{options}";
}

sub INSERT {
  my ($self, $new_rowid, @values) = @_;

  my $new_row = $self->_build_new_row(\@values);

  if (defined $new_rowid) {
    not ${$self->{rows}}->[$new_rowid]
      or die "can't INSERT : rowid $new_rowid already in use";
    ${$self->{rows}}->[$new_rowid] = $new_row;
  }
  else {
    push @${$self->{rows}}, $new_row;
    return $#${$self->{rows}};
  }
}

sub DELETE {
  my ($self, $old_rowid) = @_;

  delete ${$self->{rows}}->[$old_rowid];
}

sub UPDATE {
  my ($self, $old_rowid, $new_rowid, @values) = @_;

  my $new_row = $self->_build_new_row(\@values);

  if ($new_rowid == $old_rowid) {
    ${$self->{rows}}->[$old_rowid] = $new_row;
  }
  else {
    delete ${$self->{rows}}->[$old_rowid];
    ${$self->{rows}}->[$new_rowid] = $new_row;
  }
}


#======================================================================
package DBD::SQLeet::VirtualTable::PerlData::Cursor;
#======================================================================
use strict;
use warnings;
use base "DBD::SQLeet::VirtualTable::Cursor";


sub row {
  my ($self, $i) = @_;
  return ${$self->{vtable}{rows}}->[$i];
}

sub FILTER {
  my ($self, $idxNum, $idxStr, @vals) = @_;

  # build a method coderef to fetch matching rows
  my $perl_code = 'sub {my ($self, $i) = @_; my $row = $self->row($i); '
                .        $idxStr
                .     '}';

  # print STDERR "PERL CODE:\n", $perl_code, "\n";

  $self->{is_wanted_row} = do { no warnings; eval $perl_code }
    or die "couldn't eval q{$perl_code} : $@";

  # position the cursor to the first matching row (or to eof)
  $self->{row_ix} = -1;
  $self->NEXT;
}


sub EOF {
  my ($self) = @_;

  return $self->{row_ix} > $#${$self->{vtable}{rows}};
}

sub NEXT {
  my ($self) = @_;

  do {
    $self->{row_ix} += 1
  } until $self->EOF
       || eval {$self->{is_wanted_row}->($self, $self->{row_ix})};

  # NOTE: the eval above is required for cases when user data, injected
  # into Perl comparison operators, generates errors; for example
  # WHERE col MATCH '(foo' will die because the regex is not well formed
  # (no matching parenthesis). In such cases no row is selected and the
  # query just returns an empty list.
}


sub COLUMN {
  my ($self, $idxCol) = @_;

  my $row = $self->row($self->{row_ix});

  my $opts = $self->{vtable}{options};
  return $opts->{arrayrefs} ? $row->[$idxCol]
       : $opts->{hashrefs}  ? $row->{$self->{vtable}{headers}[$idxCol]}
       : $opts->{colref}    ? $row
       :                      die "corrupted data in ->{options}";
}

sub ROWID {
  my ($self) = @_;

  return $self->{row_ix} + 1; # rowids start at 1 in SQLite
}


1;

__END__