Merge branch 'vt_PerlData_closure'

lib/DBD/SQLite/VirtualTable/PerlData.pm

@@ -86,7 +86,7 @@ sub BEST_INDEX {
       $optype = $NUM;
     }
     else {
-      # cnstraint on regular column
+      # constraint on regular column
       my $opts = $self->{options};
       $member  = $opts->{arrayrefs} ? "\$row->[$col]"
                : $opts->{hashrefs}  ? "\$row->{$self->{headers}[$col]}"
@@ -94,9 +94,12 @@ sub BEST_INDEX {
                :                      die "corrupted data in ->{options}";
       $optype  = $self->{optypes}[$col];
     }
-    my $op    = $SQLOP2PERLOP{$constraint->{op}}[$optype];
+    my $op = $SQLOP2PERLOP{$constraint->{op}}[$optype];
-    my $quote = $op eq '=~' ? 'm' : 'q';
+    push @conditions,
-    push @conditions, "(defined($member) && $member $op ${quote}{%s})";
+      "(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++;
@@ -182,17 +185,14 @@ sub row {
 }
 
 sub FILTER {
-  my ($self, $idxNum, $idxStr, @values) = @_;
+  my ($self, $idxNum, $idxStr, @vals) = @_;
-
-  # escape '\' and '}' in values before they are sprintf'ed into q{%s}
-  @values = map {defined $_ ? quotemeta($_) : 'NULL'} @values;
 
   # build a method coderef to fetch matching rows
   my $perl_code = 'sub {my ($self, $i) = @_; my $row = $self->row($i); '
-                .        sprintf($idxStr, @values)
+                .        $idxStr
                 .     '}';
 
-  # print STDERR "PERL COODE:\n", $perl_code, "\n";
+  # print STDERR "PERL CODE:\n", $perl_code, "\n";
 
   $self->{is_wanted_row} = eval $perl_code
     or die "couldn't eval q{$perl_code} : $@";
@@ -214,7 +214,14 @@ sub NEXT {
 
   do {
     $self->{row_ix} += 1
-  } until $self->EOF || $self->{is_wanted_row}->($self, $self->{row_ix});
+  } 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.
 }
 
 

t/virtual_table/rt_99748.t

@@ -9,6 +9,20 @@ use t::lib::Test qw/connect_ok $sqlite_call/;
 use Test::More;
 use Test::NoWarnings;
 
+# tests that the MATCH operator does not allow code injection
+my @interpolation_attempts = (
+  '@{[die -1]}',
+  '(foobar',      # will die - incorrect regex
+  '(?{die 999})', # will die - Eval-group not allowed at runtime
+  '$foobar',
+  '$self->{row_ix}',
+  '$main::ARGV[ die 999 ]',
+  '@main::ARGV',
+  '$0',
+  '$self',
+ );
+
+
 # sample data
 our $perl_rows = [
   [1, 2, 'three'],
@@ -19,30 +33,7 @@ our $perl_rows = [
   [12, undef,  "data\nhas\tspaces"],
 ];
 
-# tests for security holes. All of these fail when compiling the regex
+plan tests => 4 + 2 * 15 + @interpolation_attempts + 9;
-my @interpolation_attempts = (
-  '@[{die -1}]',
-  '(?{die 999})',
- );
-
-#if ($] > 5.008008) {
-  # don't really know why, but the tests below (interpolating variables
-  # within regexes) cause segfaults under Perl <= 5.8.8, during the END
-  # phase -- probably something to do with closure destruction.
-  push @interpolation_attempts, '$foobar',
-                                '$self->{row_ix}',
-                                '$main::ARGV[ 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 => 4 + 2 * 15 + @interpolation_attempts + 8;
 
 my $dbh = connect_ok( RaiseError => 1, AutoCommit => 1 );
 
@@ -123,8 +114,7 @@ sub test_table {
 sub test_match_operator {
   my ($dbh, $table) = @_;
 
-#  my $sql = "SELECT c FROM $table WHERE c MATCH '^.i' ORDER BY c";
+  my $sql = "SELECT c FROM $table WHERE c MATCH '^.i' ORDER BY c";
-  my $sql = "SELECT c FROM $table WHERE c MATCH 'i' ORDER BY c";
   my $res = $dbh->selectcol_arrayref($sql);
   is_deeply $res, [qw/six/], $sql;
 
@@ -137,9 +127,12 @@ sub test_match_operator {
   is_deeply $res, [10, 11], $sql;
 
   $res = $dbh->selectcol_arrayref($sql, {}, '\}');
+  is_deeply $res, [10, 11], $sql;
+
+  $res = $dbh->selectcol_arrayref($sql, {}, '\\\\}');
   is_deeply $res, [11], $sql;
 
-  $res = $dbh->selectcol_arrayref($sql, {}, '\\');
+  $res = $dbh->selectcol_arrayref($sql, {}, '\\\\');
   is_deeply $res, [11], $sql;
 
   $res = $dbh->selectcol_arrayref($sql, {}, "\n");