From: Rafael Kitover <rkitover@cpan.org>
Date: Sun, 1 May 2011 21:18:35 +0000 (-0400)
Subject: Cleanup Oracle's 00a28188 / add support for update/delete with blobs in WHERE
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5e782048be95b2349b555179fdfae0bcf1e8fc0e;p=dbsrgits%2FDBIx-Class-Historic.git

Cleanup Oracle's 00a28188 / add support for update/delete with blobs in WHERE

Make a separate path for as_query, so that the sql does not pass thorugh storage
multiple times. Also do not mangle the sql unless blob binds are detected.
---

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index f14eb97..6c6efcc 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -1417,6 +1417,11 @@ for my $meth (qw/svp_begin svp_release svp_rollback/) {
 #  easier to override in NoBindVars without duping the rest.  It takes up
 #  all of _execute's args, and emits $sql, @bind.
 sub _prep_for_execute {
+  #my ($self, $op, $ident, $args) = @_;
+  return shift->_gen_sql_bind(@_)
+}
+
+sub _gen_sql_bind {
   my ($self, $op, $ident, $args) = @_;
 
   my ($sql, @bind) = $self->sql_maker->$op(
@@ -2080,8 +2085,8 @@ sub _select_args_to_query {
   my ($op, $ident, @args) =
     $self->_select_args(@_);
 
-  # my ($sql, $prepared_bind) = $self->_prep_for_execute($op, $ident, [ $select, $cond, $rs_attrs, $rows, $offset ]);
-  my ($sql, $prepared_bind) = $self->_prep_for_execute($op, $ident, \@args);
+  # my ($sql, $prepared_bind) = $self->_gen_sql_bind($op, $ident, [ $select, $cond, $rs_attrs, $rows, $offset ]);
+  my ($sql, $prepared_bind) = $self->_gen_sql_bind($op, $ident, \@args);
   $prepared_bind ||= [];
 
   return wantarray
diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
index b9bf095..ea93e29 100644
--- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
+++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
@@ -2,6 +2,9 @@ package DBIx::Class::Storage::DBI::Oracle::Generic;
 
 use strict;
 use warnings;
+use base qw/DBIx::Class::Storage::DBI/;
+use mro 'c3';
+use DBIx::Class::Carp;
 use Scope::Guard ();
 use Context::Preserve 'preserve_context';
 use Try::Tiny;
@@ -10,6 +13,10 @@ use namespace::clean;
 
 __PACKAGE__->sql_limit_dialect ('RowNum');
 __PACKAGE__->sql_quote_char ('"');
+__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::Oracle');
+__PACKAGE__->datetime_parser_type('DateTime::Format::Oracle');
+
+sub __cache_queries_with_max_lob_parts { 2 }
 
 =head1 NAME
 
@@ -77,14 +84,6 @@ versions before 9.0.
 
 =cut
 
-use base qw/DBIx::Class::Storage::DBI/;
-use mro 'c3';
-
-__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::Oracle');
-__PACKAGE__->datetime_parser_type('DateTime::Format::Oracle');
-
-sub __cache_queries_with_max_lob_parts { 2 }
-
 sub _determine_supports_insert_returning {
   my $self = shift;
 
@@ -488,16 +487,45 @@ sub _prep_for_execute {
 
   my ($sql, $bind) = $self->next::method(@_);
 
-  return ($sql, $bind) if $op ne 'select';
+  return ($sql, $bind) if $op eq 'insert';
 
-  my @sql_part = split /\?/, $sql;
-  my ($new_sql, @new_binds);
+  my $blob_bind_index;
+  for (0 .. $#$bind) {
+    $blob_bind_index->{$_} = 1 if $self->_is_lob_type(
+      $bind->[$_][0]{sqlt_datatype}
+    );
+  }
 
-  foreach my $bound (@$bind) {
-    my $data_type = $bound->[0]{sqlt_datatype}||'';
+  return ($sql, $bind) unless $blob_bind_index;
 
-    if ($self->_is_lob_type($data_type)) {
-      if (my ($col, $eq) = $sql_part[0] =~ /(?<=\s)([\w."]+)(\s*=\s*)$/) {
+  my (@sql_parts, $new_sql, @new_binds);
+
+  if ($op eq 'select' || $op eq 'delete') {
+    @sql_parts = split /\?/, $sql;
+  }
+  elsif ($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;
+
+    my $set_bind_count = $set_part =~ y/?//;
+    @new_binds = splice @$bind, 0, $set_bind_count;
+
+    @sql_parts = split /\?/, $where_part;
+    $new_sql  = $set_part;
+  }
+  else {
+    $self->throw_exception("Unsupported \$op: $op");
+  }
+
+  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;
@@ -507,15 +535,17 @@ sub _prep_for_execute {
         my @sql_frag;
 
         for my $idx (0..$#parts) {
-          push @sql_frag,
-"UTL_RAW.CAST_TO_VARCHAR2(RAWTOHEX(DBMS_LOB.SUBSTR($col, 2000, ".($idx*2000+1)."))) = ?";
+          push @sql_frag, sprintf (
+            'UTL_RAW.CAST_TO_VARCHAR2(RAWTOHEX(DBMS_LOB.SUBSTR(%s, 2000, %d))) = ?',
+            $col, ($idx*2000 + 1),
+          );
         }
 
         my $sql_frag = '( ' . (join ' AND ', @sql_frag) . ' )';
 
-        $sql_part[0] =~ s/(?<=\s)([\w."]+)(\s*=\s*)$/$sql_frag/;
+        $sql_parts[0] =~ s/$col_equality_re/$sql_frag/;
 
-        $new_sql .= shift @sql_part;
+        $new_sql .= shift @sql_parts;
 
         for my $idx (0..$#parts) {
           push @new_binds, [
@@ -529,7 +559,7 @@ sub _prep_for_execute {
         }
       }
       else {
-        $new_sql .= shift(@sql_part) . '?';
+        $new_sql .= shift(@sql_parts) . '?';
 
         push @new_binds, [
           {
@@ -541,11 +571,17 @@ sub _prep_for_execute {
       }
     }
     else {
-      $new_sql .= shift(@sql_part) . '?';
+      $new_sql .= shift(@sql_parts) . '?';
       push @new_binds, $bound;
     }
   }
-  $new_sql .= join '', @sql_part;
+
+  if (@sql_parts > 1) {
+    carp "There are more placeholders than binds, this should not happen!";
+    @sql_parts = join ('?', @sql_parts);
+  }
+
+  $new_sql .= $sql_parts[0];
 
   return ($new_sql, \@new_binds);
 }
diff --git a/lib/DBIx/Class/Storage/DBI/Replicated.pm b/lib/DBIx/Class/Storage/DBI/Replicated.pm
index 33e553d..7f40e27 100644
--- a/lib/DBIx/Class/Storage/DBI/Replicated.pm
+++ b/lib/DBIx/Class/Storage/DBI/Replicated.pm
@@ -300,6 +300,7 @@ my $method_dispatch = {
     _per_row_update_delete
     _dbh_execute_inserts_with_no_binds
     _select_args_to_query
+    _gen_sql_bind
     _svp_generate_name
     _multipk_update_delete
     _normalize_connect_info
diff --git a/t/73oracle.t b/t/73oracle.t
index bbee812..6604e94 100644
--- a/t/73oracle.t
+++ b/t/73oracle.t
@@ -407,27 +407,47 @@ sub _run_tests {
         $rs->create( { 'id' => $id, blob => "blob:$str", clob => "clob:$str" } )
       } "inserted $size without dying";
 
+      my %kids = %{$schema->storage->_dbh->{CachedKids}};
       my @objs = $rs->search({ blob => "blob:$str", clob => "clob:$str" })->all;
-      is (@objs, 1, 'One row found matching on both LOBs');
+      is_deeply (
+        $schema->storage->_dbh->{CachedKids},
+        \%kids,
+        'multi-part LOB equality query was not cached',
+      ) if $size eq 'large';
+      is @objs, 1, 'One row found matching on both LOBs';
       ok (try { $objs[0]->blob }||'' eq "blob:$str", 'blob inserted/retrieved correctly');
       ok (try { $objs[0]->clob }||'' eq "clob:$str", 'clob inserted/retrieved correctly');
 
-      if ($size eq 'large') { # check that prepare_cached was NOT used
-        my $sql = ${ $rs->search({ blob => "blob:$str", clob => "clob:$str" })
-          ->as_query }->[0];
-
-        ok((not exists $schema->storage->_dbh->{CachedKids}{$sql}),
-          'multi-part LOB equality query was not cached');
-      }
-
       @objs = $rs->search({ clob => { -like => 'clob:%' } })->all;
       ok (@objs, 'rows found matching CLOB with a LIKE query');
 
-      ok(my $subq = $rs->search({ blob => "blob:$str", clob => "clob:$str" })
-        ->get_column('id')->as_query);
+      ok(my $subq = $rs->search(
+        { blob => "blob:$str", clob => "clob:$str" },
+        {
+          from => \ "(SELECT * FROM ${q}bindtype_test${q} WHERE ${q}id${q} != ?) ${q}me${q}",
+          bind => [ [ undef => 12345678 ] ],
+        }
+      )->get_column('id')->as_query);
 
       @objs = $rs->search({ id => { -in => $subq } })->all;
       is (@objs, 1, 'One row found matching on both LOBs as a subquery');
+
+      lives_ok {
+        $rs->search({ blob => "blob:$str", clob => "clob:$str" })
+          ->update({ blob => 'updated blob', clob => 'updated clob' });
+      } 'blob UPDATE with WHERE clause survived';
+
+      @objs = $rs->search({ blob => "updated blob", clob => 'updated clob' })->all;
+      is @objs, 1, 'found updated row';
+      ok (try { $objs[0]->blob }||'' eq "updated blob", 'blob updated/retrieved correctly');
+      ok (try { $objs[0]->clob }||'' eq "updated clob", 'clob updated/retrieved correctly');
+
+      lives_ok {
+        $rs->search({ blob => "updated blob", clob => "updated clob" })
+          ->delete;
+      } 'blob DELETE with WHERE clause survived';
+      @objs = $rs->search({ blob => "updated blob", clob => 'updated clob' })->all;
+      is @objs, 0, 'row deleted successfully';
     }
 
     $schema->storage->debug ($orig_debug);
diff --git a/t/93autocast.t b/t/93autocast.t
index a0eb9d3..95d2b92 100644
--- a/t/93autocast.t
+++ b/t/93autocast.t
@@ -5,6 +5,7 @@ use Test::More;
 use lib qw(t/lib);
 use DBICTest;
 use DBIC::SqlMakerTest;
+use DBIC::DebugObj;
 
 { # Fake storage driver for sqlite with autocast
     package DBICTest::SQLite::AutoCast;
@@ -33,23 +34,26 @@ my $rs = $schema->resultset ('CD')->search ({
   'tracks.last_updated_at' => { '!=', undef },
   'tracks.last_updated_on' => { '<', 2009 },
   'tracks.position' => 4,
-  'me.single_track' => \[ '= ?', [ single_track => [1, 2, 3 ] ] ],
+  'me.single_track' => \[ '= ?', [ single_track => 1 ] ],
 }, { join => 'tracks' });
 
-my $bind = [
-  [ { sqlt_datatype => 'integer', dbic_colname => 'cdid' }
-    => 5 ],
-  [ { sqlt_datatype => 'integer', dbic_colname => 'single_track' }
-    => [ 1, 2, 3] ],
-  [ { sqlt_datatype => 'datetime', dbic_colname => 'tracks.last_updated_on' }
-    => 2009 ],
-  [ { sqlt_datatype => 'int', dbic_colname => 'tracks.position' }
-    => 4 ],
-];
+my ($sql, @bind);
+my $debugobj = DBIC::DebugObj->new (\$sql, \@bind);
+my $storage = $schema->storage;
+my ($orig_debug, $orig_debugobj) = ($storage->debug, $storage->debugobj);
+$storage->debugobj ($debugobj);
+$storage->debug (1);
 
+# the quoting is a debugobj thing, not dbic-internals
+my $bind = [ map { "'$_'" } qw/
+  5 1 2009 4
+/];
+
+$rs->all;
 is_same_sql_bind (
-  $rs->as_query,
-  '(
+  $sql,
+  \@bind,
+  '
     SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
       FROM cd me
       LEFT JOIN track tracks ON tracks.cd = me.cdid
@@ -59,16 +63,18 @@ is_same_sql_bind (
       AND tracks.last_updated_at IS NOT NULL
       AND tracks.last_updated_on < ?
       AND tracks.position = ?
-  )',
+  ',
   $bind,
   'expected sql with casting off',
 );
 
 $schema->storage->auto_cast (1);
 
+$rs->all;
 is_same_sql_bind (
-  $rs->as_query,
-  '(
+  $sql,
+  \@bind,
+  '
     SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
       FROM cd me
       LEFT JOIN track tracks ON tracks.cd = me.cdid
@@ -78,9 +84,12 @@ is_same_sql_bind (
       AND tracks.last_updated_at IS NOT NULL
       AND tracks.last_updated_on < CAST (? AS DateTime)
       AND tracks.position = ?
-  )',
+  ',
   $bind,
   'expected sql with casting on',
 );
 
+$storage->debugobj ($orig_debugobj);
+$storage->debug ($orig_debug);
+
 done_testing;