_cond_for_update_delete is hopelessly broken attempting to introspect…

… SQLA1. Replace with a horrific but effective hack
Perl5 · Nov 12, 2009 · af668ad · af668ad
1 parent 10176e1
commit af668ad
Show file tree

Hide file tree

Showing 4 changed files with 41 additions and 67 deletions.
diff --git a/Changes b/Changes
@@ -35,6 +35,7 @@ Revision history for DBIx::Class
         - Fix in_storage() to return 1|0 as per existing documentation
         - Centralize handling of _determine_driver calls prior to certain
           ::Storage::DBI methods
+        - Fix update/delete arbitrary condition handling (RT#51409)
         - POD improvements
 
 0.08112 2009-09-21 10:57:00 (UTC)

diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
@@ -1544,70 +1544,11 @@ sub _rs_update_delete {
     return $rsrc->storage->$op(
       $rsrc,
       $op eq 'update' ? $values : (),
-      $self->_cond_for_update_delete,
+      $self->{cond},
     );
   }
 }
 
-
-# _cond_for_update_delete
-#
-# update/delete require the condition to be modified to handle
-# the differing SQL syntax available.  This transforms the $self->{cond}
-# appropriately, returning the new condition.
-
-sub _cond_for_update_delete {
-  my ($self, $full_cond) = @_;
-  my $cond = {};
-
-  $full_cond ||= $self->{cond};
-  # No-op. No condition, we're updating/deleting everything
-  return $cond unless ref $full_cond;
-
-  if (ref $full_cond eq 'ARRAY') {
-    $cond = [
-      map {
-        my %hash;
-        foreach my $key (keys %{$_}) {
-          $key =~ /([^.]+)$/;
-          $hash{$1} = $_->{$key};
-        }
-        \%hash;
-      } @{$full_cond}
-    ];
-  }
-  elsif (ref $full_cond eq 'HASH') {
-    if ((keys %{$full_cond})[0] eq '-and') {
-      $cond->{-and} = [];
-      my @cond = @{$full_cond->{-and}};
-       for (my $i = 0; $i < @cond; $i++) {
-        my $entry = $cond[$i];
-        my $hash;
-        if (ref $entry eq 'HASH') {
-          $hash = $self->_cond_for_update_delete($entry);
-        }
-        else {
-          $entry =~ /([^.]+)$/;
-          $hash->{$1} = $cond[++$i];
-        }
-        push @{$cond->{-and}}, $hash;
-      }
-    }
-    else {
-      foreach my $key (keys %{$full_cond}) {
-        $key =~ /([^.]+)$/;
-        $cond->{$1} = $full_cond->{$key};
-      }
-    }
-  }
-  else {
-    $self->throw_exception("Can't update/delete on resultset with condition unless hash or array");
-  }
-
-  return $cond;
-}
-
-
 =head2 update
 
 =over 4

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
@@ -1549,20 +1549,35 @@ sub _dbh_execute_inserts_with_no_binds {
 }
 
 sub update {
-  my ($self, $source, @args) = @_; 
+  my ($self, $source, $data, $where, @args) = @_; 
 
-  my $bind_attributes = $self->source_bind_attributes($source);
+  my $bind_attrs = $self->source_bind_attributes($source);
+  $where = $self->_strip_cond_qualifiers ($where);
 
-  return $self->_execute('update' => [], $source, $bind_attributes, @args);
+  return $self->_execute('update' => [], $source, $bind_attrs, $data, $where, @args);
 }
 
 
 sub delete {
-  my ($self, $source, @args) = @_; 
+  my ($self, $source, $where, @args) = @_;
 
   my $bind_attrs = $self->source_bind_attributes($source);
+  $where = $self->_strip_cond_qualifiers ($where);
+
+  return $self->_execute('delete' => [], $source, $bind_attrs, $where, @args);
+}
+
+sub _strip_cond_qualifiers {
+  my ($self, $where) = @_;
+
+  my $sqlmaker = $self->sql_maker;
+  my ($sql, @bind) = $sqlmaker->_recurse_where($where);
+  return undef unless $sql;
+
+  my ($qquot, $qsep) = map { quotemeta $_ } ( ($sqlmaker->quote_char||''), ($sqlmaker->name_sep||'.') );
+  $sql =~ s/ (?: $qquot [\w\-]+ $qquot | [\w\-]+ ) $qsep //gx;
 
-  return $self->_execute('delete' => [], $source, $bind_attrs, @args);
+  return \[$sql, @bind];
 }
 
 # We were sent here because the $rs contains a complex search

diff --git a/t/resultset/update_delete.t b/t/resultset/update_delete.t
@@ -79,8 +79,12 @@ throws_ok (
 );
 
 # grouping on PKs only should pass
-$sub_rs->search ({}, { group_by => [ reverse $sub_rs->result_source->primary_columns ] })     # reverse to make sure the comaprison works
-          ->update ({ pilot_sequence => \ 'pilot_sequence + 1' });
+$sub_rs->search (
+  {},
+  {
+    group_by => [ reverse $sub_rs->result_source->primary_columns ],     # reverse to make sure the PK-list comaprison works
+  },
+)->update ({ pilot_sequence => \ 'pilot_sequence + 1' });
 
 is_deeply (
   [ $tkfks->search ({ autopilot => [qw/a b x y/]}, { order_by => 'autopilot' })
@@ -90,6 +94,19 @@ is_deeply (
   'Only two rows incremented',
 );
 
+# also make sure weird scalarref usage works (RT#51409)
+$tkfks->search (
+  \ 'pilot_sequence BETWEEN 11 AND 21',
+)->update ({ pilot_sequence => \ 'pilot_sequence + 1' });
+
+is_deeply (
+  [ $tkfks->search ({ autopilot => [qw/a b x y/]}, { order_by => 'autopilot' })
+            ->get_column ('pilot_sequence')->all 
+  ],
+  [qw/12 22 30 40/],
+  'Only two rows incremented (where => scalarref works)',
+);
+
 $sub_rs->delete;
 
 is ($tkfks->count, $tkfk_cnt -= 2, 'Only two rows deleted');