view release on metacpan or  search on metacpan

lib/DBD/SQLite/VirtualTable/PerlData.pm  view on Meta::CPAN

  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::SQLite::VirtualTable::PerlData::Cursor;
#======================================================================
use strict;
use warnings;
use base "DBD::SQLite::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__

=head1 NAME

DBD::SQLite::VirtualTable::PerlData -- virtual table hooked to Perl data

=head1 SYNOPSIS

Within Perl :

  $dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData");