RT#99748

- added support for undef (NULLs) in comparisons
- new test file t/virtual_table/rt_99748.t for testing nulls and comparing vtable with a regular table
- tests that no security holes can be inserted in compiled regexes
- ROWIDs start at 1, not at 0
- replaced qr{..} by m{..}

MANIFEST

@@ -121,6 +121,7 @@ t/virtual_table/10_filecontent.t
 t/virtual_table/11_filecontent_fulltext.t
 t/virtual_table/20_perldata.t
 t/virtual_table/21_perldata_charinfo.t
+t/virtual_table/rt_99748.t
 typemap
 util/getsqlite.pl
 xt/meta.t

lib/DBD/SQLite/VirtualTable/PerlData.pm

@@ -95,8 +95,8 @@ sub BEST_INDEX {
       $optype  = $self->{optypes}[$col];
     }
     my $op    = $SQLOP2PERLOP{$constraint->{op}}[$optype];
-    my $quote = $op eq '=~' ? 'qr' : 'q';
-    push @conditions, "($member $op ${quote}{%s})";
+    my $quote = $op eq '=~' ? 'm' : 'q';
+    push @conditions, "(defined($member) && $member $op ${quote}{%s})";
 
     # info passed back to the SQLite core -- see vtab.html in sqlite doc
     $constraint->{argvIndex} = $ix++;
@@ -125,7 +125,8 @@ sub _build_new_row {
 
   my $opts = $self->{options};
   return $opts->{arrayrefs} ? $values
-       : $opts->{hashrefs}  ? { map {$self->{headers}->[$_], $values->[$_]} (0 .. @{$self->{headers}} - 1) }
+       : $opts->{hashrefs}  ? { map {$self->{headers}->[$_], $values->[$_]}
+                                    (0 .. @{$self->{headers}} - 1) }
        : $opts->{colref}    ? $values->[0]
        :                      die "corrupted data in ->{options}";
 }
@@ -191,7 +192,7 @@ sub FILTER {
                 .        sprintf($idxStr, @values)
                 .     '}';
 
-  # print STDERR $perl_code, "\n";
+  # print STDERR "PERL COODE:\n", $perl_code, "\n";
 
   $self->{is_wanted_row} = eval $perl_code
     or die "couldn't eval q{$perl_code} : $@";
@@ -232,7 +233,7 @@ sub COLUMN {
 sub ROWID {
   my ($self) = @_;
 
-  return $self->{row_ix};
+  return $self->{row_ix} + 1; # rowids start at 1 in SQLite
 }
 
 
@@ -421,7 +422,7 @@ Here is how such a program would look like :
   # Declare a global arrayref containing the values. Here we assume
   # they are taken from @ARGV, but any other datasource would do.
   # Note the use of "our" instead of "my".
-  our $valuess = \@ARGV; 
+  our $values = \@ARGV; 
   
   # register the module and declare the virtual table
   $dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData");

t/virtual_table/20_perldata.t

@@ -48,7 +48,7 @@ is $res->[1]{a}, 1, 'got 1 in second a';
 
 $sql = "SELECT rowid FROM vtb WHERE c = 'six'";
 $res = $dbh->selectall_arrayref($sql, {Slice => {}});
-is_deeply $res, [{rowid => 1}], $sql;
+is_deeply $res, [{rowid => 2}], $sql;
 
 $sql = "SELECT c FROM vtb WHERE c MATCH '^.i' ORDER BY c";
 $res = $dbh->selectcol_arrayref($sql);

t/virtual_table/rt_99748.t

@@ -0,0 +1,101 @@
+#!/usr/bin/perl
+use strict;
+BEGIN {
+	$|  = 1;
+	$^W = 1;
+}
+
+
+use t::lib::Test qw/connect_ok/;
+use Test::More;
+use Test::NoWarnings;
+
+# sample data
+our $perl_rows = [
+  [1, 2, 'three'],
+  [4, undef, 'six'  ],
+  [7, 8, undef ],
+];
+
+# tests for security holes. All of these fail when compiling the regex
+my @interpolation_attempts = (
+  '@[{die -1}]',
+  '$foobar',
+  '$self->{row_ix}',
+  '(?{die 999})',
+  '(?[die 999])',
+ );
+
+# unfortunately the examples below don't fail, but I don't know how to
+# prevent variable interpolation (that we don't want) while keeping
+# character interpolation like \n, \t, etc. (that we do want)
+  # '@main::ARGV',
+  # '$0',
+  # '$self',
+
+plan tests => 25 + @interpolation_attempts;
+
+my $dbh = connect_ok( RaiseError => 1, AutoCommit => 1 );
+
+# create a regular table so that we can compare results with the virtual table
+$dbh->do("CREATE TABLE rtb(a INT, b INT, c TEXT)");
+my $sth = $dbh->prepare("INSERT INTO rtb(a, b, c) VALUES (?, ?, ?)");
+$sth->execute(@$_) foreach @$perl_rows;
+
+# create the virtual table
+ok $dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData"),
+   "create_module";
+ok $dbh->do(<<""), "create vtable";
+  CREATE VIRTUAL TABLE vtb USING perl(a INT, b INT, c TEXT,
+                                      arrayrefs="main::perl_rows")
+
+# run same tests on both the regular and the virtual table
+test_table($dbh, 'rtb');
+test_table($dbh, 'vtb', 1);
+
+
+
+sub test_table {
+  my ($dbh, $table, $should_test_match) = @_;
+
+  my $sql = "SELECT rowid, * FROM $table";
+  my $res = $dbh->selectall_arrayref($sql, {Slice => {}});
+  is scalar(@$res), 3, "$sql: got 3 rows";
+  is $res->[0]{a}, 1, 'got 1 in a';
+  is $res->[0]{b}, 2, 'got undef in b';
+
+  $sql  = "SELECT a FROM $table WHERE b < 8 ORDER BY a";
+  $res = $dbh->selectcol_arrayref($sql);
+  is scalar(@$res), 1, "$sql: got 1 row";
+  is_deeply $res, [1], "got 1 in a";
+
+  $sql = "SELECT rowid FROM $table WHERE c = 'six'";
+  $res = $dbh->selectall_arrayref($sql, {Slice => {}});
+  is_deeply $res, [{rowid => 2}], $sql;
+
+  $sql = "SELECT a FROM $table WHERE b IS NULL ORDER BY a";
+  $res = $dbh->selectcol_arrayref($sql);
+  is_deeply $res, [4], $sql;
+
+  $sql = "SELECT a FROM $table WHERE b IS NOT NULL ORDER BY a";
+  $res = $dbh->selectcol_arrayref($sql);
+  is_deeply $res, [1, 7], $sql;
+
+  $sql = "SELECT a FROM $table WHERE c IS NULL ORDER BY a";
+  $res = $dbh->selectcol_arrayref($sql);
+  is_deeply $res, [7], $sql;
+
+  $sql = "SELECT a FROM $table WHERE c IS NOT NULL ORDER BY a";
+  $res = $dbh->selectcol_arrayref($sql);
+  is_deeply $res, [1, 4], $sql;
+
+  if ($should_test_match) {
+    $sql = "SELECT c FROM $table WHERE c MATCH '^.i' ORDER BY c";
+    $res = $dbh->selectcol_arrayref($sql);
+    is_deeply $res, [qw/six/], $sql;
+
+    $sql = "SELECT c FROM $table WHERE c MATCH ? ORDER BY c";
+    ok !eval{$dbh->selectcol_arrayref($sql, {}, $_); 1}, $_ # "$_ : $@"
+      foreach @interpolation_attempts;
+  }
+}