File Coverage

blib/lib/DBD/SQLite/VirtualTable/FileContent.pm

Criterion	Covered	Total	%
statement	107	113	94.6
branch	22	32	68.7
condition	1	2	50.0
subroutine	17	18	94.4
pod	3	3	100.0
total	150	168	89.2

#======================================================================
package DBD::SQLite::VirtualTable::FileContent;
#======================================================================
use strict;
use warnings;
use base 'DBD::SQLite::VirtualTable';

my %option_ok = map {($_ => 1)} qw/source content_col path_col
                                   expose root get_content/;

my %defaults = (
  content_col => "content",
  path_col    => "path",
  expose      => "*",
  get_content => "DBD::SQLite::VirtualTable::FileContent::get_content",
);


#----------------------------------------------------------------------
# object instanciation
#----------------------------------------------------------------------

sub NEW {
  my $class = shift;

  my $self  = $class->_PREPARE_SELF(@_);

  local $" = ", "; # for array interpolation in strings

  # initial parameter check
  !@{$self->{columns}}
    or die "${class}->NEW(): illegal options: @{$self->{columns}}";
  $self->{options}{source}
    or die "${class}->NEW(): missing (source=...)";
  my @bad_options = grep {!$option_ok{$_}} keys %{$self->{options}};
  !@bad_options
    or die "${class}->NEW(): bad options: @bad_options";

  # defaults ... tempted to use //= but we still want to support perl 5.8 :-(
  foreach my $k (keys %defaults) {
    defined $self->{options}{$k}
      or $self->{options}{$k} = $defaults{$k};
  }

  # get list of columns from the source table
  my $src_table  = $self->{options}{source};
  my $sql        = "PRAGMA table_info($src_table)";
  my $dbh        = ${$self->{dbh_ref}}; # can't use method ->dbh, not blessed yet
  my $src_info   = $dbh->selectall_arrayref($sql, {Slice => [1, 2]});
  @$src_info
    or die "${class}->NEW(source=$src_table): no such table in database";

  # associate each source colname with its type info or " " (should eval true)
  my %src_col = map  { ($_->[0] => $_->[1] || " ") } @$src_info;


  # check / complete the exposed columns
  my @exposed_cols;
  if ($self->{options}{expose} eq '*') {
    @exposed_cols = map {$_->[0]} @$src_info;
  }
  else {
    @exposed_cols = split /\s*,\s*/, $self->{options}{expose};
    my @bad_cols  = grep { !$src_col{$_} } @exposed_cols;
    die "table $src_table has no column named @bad_cols" if @bad_cols;
  }
  for (@exposed_cols) {
    die "$class: $self->{options}{content_col} cannot be both the "
      . "content_col and an exposed col" if $_ eq $self->{options}{content_col};
  }

  # build the list of columns for this table
  $self->{columns} = [ "$self->{options}{content_col} TEXT",
                       map {"$_ $src_col{$_}"} @exposed_cols ];

  # acquire a coderef to the get_content() implementation, which
  # was given as a symbolic reference in %options
  no strict 'refs';
  $self->{get_content} = \ &{$self->{options}{get_content}};

  bless $self, $class;
}

sub _build_headers {
  my $self = shift;

  my $cols = $self->sqlite_table_info;

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


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

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

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

  my @conditions;
  my $ix = 0;
  foreach my $constraint (grep {$_->{usable}} @$constraints) {
    my $col     = $constraint->{col};

    # if this is the content column, skip because we can't filter on it
    next if $col == 0;

    # for other columns, build a fragment for SQL WHERE on the underlying table
    my $colname = $col == -1 ? "rowid" : $self->{headers}[$col];
    push @conditions, "$colname $constraint->{op} ?";
    $constraint->{argvIndex} = $ix++;
    $constraint->{omit}      = 1;     # SQLite doesn't need to re-check the op
  }

  # TODO : exploit $order_by to add ordering clauses within idxStr

  my $outputs = {
    idxNum           => 1,
    idxStr           => join(" AND ", @conditions),
    orderByConsumed  => 0,
    estimatedCost    => 1.0,
    estimatedRows    => undef,
   };

  return $outputs;
}


#----------------------------------------------------------------------
# method for preventing updates
#----------------------------------------------------------------------

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

  die "attempt to update a readonly virtual table";
}


#----------------------------------------------------------------------
# file slurping function (not a method!)
#----------------------------------------------------------------------

sub get_content {
  my ($path, $root) = @_;

  $path = "$root/$path" if $root;

  my $content = "";
  if (open my $fh, "<", $path) {
    local $/;          # slurp the whole file into a scalar
    $content = <$fh>;
    close $fh;
  }
  else {
    warn "can't open $path";
  }

  return $content;
}



#======================================================================
package DBD::SQLite::VirtualTable::FileContent::Cursor;
#======================================================================
use strict;
use warnings;
use base "DBD::SQLite::VirtualTable::Cursor";


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

  my $vtable = $self->{vtable};

  # build SQL
  local $" = ", ";
  my @cols = @{$vtable->{headers}};
  $cols[0] = 'rowid';                 # replace the content column by the rowid
  push @cols, $vtable->{options}{path_col}; # path col in last position
  my $sql  = "SELECT @cols FROM $vtable->{options}{source}";
  $sql .= " WHERE $idxStr" if $idxStr;

  # request on the index table
  my $dbh = $vtable->dbh;
  $self->{sth} = $dbh->prepare($sql)
    or die DBI->errstr;
  $self->{sth}->execute(@values);
  $self->{row} = $self->{sth}->fetchrow_arrayref;

  return;
}


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

  return !$self->{row};
}

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

  $self->{row} = $self->{sth}->fetchrow_arrayref;
}

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

  return $idxCol == 0 ? $self->file_content : $self->{row}[$idxCol];
}

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

  return $self->{row}[0];
}

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

  my $root = $self->{vtable}{options}{root};
  my $path = $self->{row}[-1];
  my $get_content_func = $self->{vtable}{get_content};

  return $get_content_func->($path, $root);
}


1;

__END__