From: Rafael Kitover <rkitover@cpan.org>
Date: Mon, 18 Jul 2011 16:28:48 +0000 (-0400)
Subject: Oracle: fix LOB conversions for non-LOBs (RT#69548)
X-Git-Tag: v0.08194~5
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=00819de0cb0c81bbadaed7a7312cc575efae1bb8;p=dbsrgits%2FDBIx-Class.git

Oracle: fix LOB conversions for non-LOBs (RT#69548)

Recalculates the LOB binds index for UPDATE queries, as it was
erroneosly not recalculated before. This resulted in non-LOB columns
being treated as LOBs by the SQL mangling code.

ribasushi also optimizes the code for the predominant case of queries
without LOBs in the WHERE clause.
---

diff --git a/Changes b/Changes
index a9034d0..d8b4f58 100644
--- a/Changes
+++ b/Changes
@@ -4,6 +4,8 @@ Revision history for DBIx::Class
         - Fix $rs->populate([]) to be a no-op rather than an exception
         - Overhaul t/53lean_startup.t to better dodge false positives
         - Stop Data::Compare from loading random plugins
+        - Oracle: Recalculate LOB bind indices for UPDATE with LOBs in WHERE
+          (RT#69548)
 
 0.08193 2011-07-14 17:00 (UTC)
     * New Features / Changes
diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
index 81dbeed..cfefc77 100644
--- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
+++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
@@ -495,94 +495,101 @@ sub _prep_for_execute {
   my $self = shift;
   my ($op) = @_;
 
-  my ($sql, $bind) = $self->next::method(@_);
+  return $self->next::method(@_)
+    if $op eq 'insert';
 
-  return ($sql, $bind) if $op eq 'insert';
+  my ($sql, $bind) = $self->next::method(@_);
 
-  my $blob_bind_index;
-  for (0 .. $#$bind) {
-    $blob_bind_index->{$_} = 1 if $self->_is_lob_type(
+  my $lob_bind_indices = { map {
+    (
       $bind->[$_][0]{sqlt_datatype}
-    );
-  }
+        and
+      $self->_is_lob_type($bind->[$_][0]{sqlt_datatype})
+    ) ? ( $_ => 1 ) : ()
+  } ( 0 .. $#$bind ) };
 
-  return ($sql, $bind) unless $blob_bind_index;
+  return ($sql, $bind) unless %$lob_bind_indices;
 
-  my (@sql_parts, $new_sql, @new_binds);
-
-  if ($op eq 'select' || $op eq 'delete') {
-    @sql_parts = split /\?/, $sql;
-  }
-  elsif ($op eq 'update') {
+  my ($final_sql, @final_binds);
+  if ($op eq 'update') {
     $self->throw_exception('Update with complex WHERE clauses currently not supported')
       if $sql =~ /\bWHERE\b .+ \bWHERE\b/xs;
 
-    my ($set_part, $where_part) = $sql =~ /^ (.+?) ( \bWHERE\b .+) /xs;
+    ($final_sql, $sql) = $sql =~ /^ (.+?) ( \bWHERE\b .+) /xs;
+
+    if (my $set_bind_count = $final_sql =~ y/?//) {
 
-    my $set_bind_count = $set_part =~ y/?//;
-    @new_binds = splice @$bind, 0, $set_bind_count;
+      delete $lob_bind_indices->{$_} for (0 .. ($set_bind_count - 1));
 
-    @sql_parts = split /\?/, $where_part;
-    $new_sql  = $set_part;
+      # bail if only the update part contains blobs
+      return ($sql, $bind) unless %$lob_bind_indices;
+
+      @final_binds = splice @$bind, 0, $set_bind_count;
+      $lob_bind_indices = { map
+        { $_ - $set_bind_count => $lob_bind_indices->{$_} }
+        keys %$lob_bind_indices
+      };
+    }
   }
-  else {
+  elsif ($op ne 'select' and $op ne 'delete') {
     $self->throw_exception("Unsupported \$op: $op");
   }
 
+  my @sql_parts = split /\?/, $sql;
+
   my $col_equality_re = qr/ (?<=\s) ([\w."]+) (\s*=\s*) $/x;
 
   for my $b_idx (0 .. $#$bind) {
     my $bound = $bind->[$b_idx];
 
-    if ($blob_bind_index->{$b_idx}) {
-      if (my ($col, $eq) = $sql_parts[0] =~ $col_equality_re) {
-        my $data = $bound->[1];
-
-        $data = "$data" if ref $data;
+    if (
+      $lob_bind_indices->{$b_idx}
+        and
+      my ($col, $eq) = $sql_parts[0] =~ $col_equality_re
+    ) {
+      my $data = $bound->[1];
 
-        my @parts = unpack '(a2000)*', $data;
+      $data = "$data" if ref $data;
 
-        my @sql_frag;
+      my @parts = unpack '(a2000)*', $data;
 
-        for my $idx (0..$#parts) {
-          push @sql_frag, sprintf (
-            'UTL_RAW.CAST_TO_VARCHAR2(RAWTOHEX(DBMS_LOB.SUBSTR(%s, 2000, %d))) = ?',
-            $col, ($idx*2000 + 1),
-          );
-        }
+      my @sql_frag;
 
-        my $sql_frag = '( ' . (join ' AND ', @sql_frag) . ' )';
+      for my $idx (0..$#parts) {
+        push @sql_frag, sprintf (
+          'UTL_RAW.CAST_TO_VARCHAR2(RAWTOHEX(DBMS_LOB.SUBSTR(%s, 2000, %d))) = ?',
+          $col, ($idx*2000 + 1),
+        );
+      }
 
-        $sql_parts[0] =~ s/$col_equality_re/$sql_frag/;
+      my $sql_frag = '( ' . (join ' AND ', @sql_frag) . ' )';
 
-        $new_sql .= shift @sql_parts;
+      $sql_parts[0] =~ s/$col_equality_re/$sql_frag/;
 
-        for my $idx (0..$#parts) {
-          push @new_binds, [
-            {
-              %{ $bound->[0] },
-              _ora_lob_autosplit_part => $idx,
-              dbd_attrs => undef,
-            },
-            $parts[$idx]
-          ];
-        }
-      }
-      else {
-        $new_sql .= shift(@sql_parts) . '?';
+      $final_sql .= shift @sql_parts;
 
-        push @new_binds, [
+      for my $idx (0..$#parts) {
+        push @final_binds, [
           {
             %{ $bound->[0] },
+            _ora_lob_autosplit_part => $idx,
             dbd_attrs => undef,
           },
-          $bound->[1],
+          $parts[$idx]
         ];
       }
     }
     else {
-      $new_sql .= shift(@sql_parts) . '?';
-      push @new_binds, $bound;
+      $final_sql .= shift(@sql_parts) . '?';
+      push @final_binds, $lob_bind_indices->{$b_idx}
+        ? [
+          {
+            %{ $bound->[0] },
+            dbd_attrs => undef,
+          },
+          $bound->[1],
+        ] : $bound
+      ;
     }
   }
 
@@ -591,9 +598,9 @@ sub _prep_for_execute {
     @sql_parts = join ('?', @sql_parts);
   }
 
-  $new_sql .= $sql_parts[0];
+  $final_sql .= $sql_parts[0];
 
-  return ($new_sql, \@new_binds);
+  return ($final_sql, \@final_binds);
 }
 
 # Savepoints stuff.
diff --git a/t/73oracle.t b/t/73oracle.t
index aafd1f0..6e1026e 100644
--- a/t/73oracle.t
+++ b/t/73oracle.t
@@ -393,7 +393,6 @@ sub _run_tests {
 
     # disable BLOB mega-output
     my $orig_debug = $schema->storage->debug;
-    $schema->storage->debug (0);
 
     local $TODO = 'Something is confusing column bindtype assignment when quotes are active'
                 . ': https://rt.cpan.org/Ticket/Display.html?id=64206'
@@ -403,6 +402,13 @@ sub _run_tests {
     foreach my $size (qw( small large )) {
       $id++;
 
+      if ($size eq 'small') {
+        $schema->storage->debug($orig_debug);
+      }
+      elsif ($size eq 'large') {
+        $schema->storage->debug(0);
+      }
+
       my $str = $binstr{$size};
       lives_ok {
         $rs->create( { 'id' => $id, blob => "blob:$str", clob => "clob:$str" } )
@@ -441,7 +447,7 @@ sub _run_tests {
       is (@objs, 1, 'One row found matching on both LOBs as a subquery');
 
       lives_ok {
-        $rs->search({ blob => "blob:$str", clob => "clob:$str" })
+        $rs->search({ id => $id, blob => "blob:$str", clob => "clob:$str" })
           ->update({ blob => 'updated blob', clob => 'updated clob' });
       } 'blob UPDATE with WHERE clause survived';