From: Peter Rabbitson <ribasushi@cpan.org>
Date: Tue, 5 Aug 2014 10:13:16 +0000 (+0200)
Subject: Fix both a dubious test and a regression in populate args immutability
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0a768c9067712d4f9512748c315c617367fe8dc4;p=dbsrgits%2FDBIx-Class-Historic.git

Fix both a dubious test and a regression in populate args immutability

The rewrite in d0cefd99 optimized populate enough that the same data structure
would now make it all the way to the stringifier in ::Storage. This was not
caught due to a deficient test.

Read diff under -w for maximum sense
---

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index b3eda3e..fe503b4 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -2038,16 +2038,6 @@ sub insert {
 sub insert_bulk {
   my ($self, $source, $cols, $data) = @_;
 
-  # FIXME SUBOPTIMAL - DBI needs fixing to always stringify regardless of DBD
-  # For the time being forcibly stringify whatever is stringifiable
-  # ResultSet::populate() hands us a copy - safe to mangle
-  for my $r (0 .. $#$data) {
-    for my $c (0 .. $#{$data->[$r]}) {
-      $data->[$r][$c] = "$data->[$r][$c]"
-        if ( length ref $data->[$r][$c] and is_plain_value $data->[$r][$c] );
-    }
-  }
-
   my $colinfos = $source->columns_info($cols);
 
   local $self->{_autoinc_supplied_for_op} =
@@ -2282,7 +2272,7 @@ sub _dbh_execute_for_fetch {
     return undef if ++$fetch_row_idx > $#$data;
 
     return [ map {
-      ! defined $_->{_literal_bind_subindex}
+      my $v = ! defined $_->{_literal_bind_subindex}
 
         ? $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ]
 
@@ -2294,7 +2284,14 @@ sub _dbh_execute_for_fetch {
             [ ${ $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ]}->[ $_->{_literal_bind_subindex} ] ],
             {},     # a fake column_info bag
           )->[0][1]
+      ;
 
+      # FIXME SUBOPTIMAL - DBI needs fixing to always stringify regardless of DBD
+      # For the time being forcibly stringify whatever is stringifiable
+      (length ref $v and is_plain_value $v)
+        ? "$v"
+        : $v
+      ;
     } map { $_->[0] } @$proto_bind ];
   };
 
diff --git a/t/100populate.t b/t/100populate.t
index 16c1e6d..57efc72 100644
--- a/t/100populate.t
+++ b/t/100populate.t
@@ -395,79 +395,108 @@ warnings_like {
   my $rank = Math::BigInt->new(42);
 
   my $args = {
-    'stringifying objects after regular values' => [ map
-      { { name => $_, rank => $rank } }
-      (
+    'stringifying objects after regular values' => { AoA => [
+      [qw( name rank )],
+      ( map { [ $_, $rank ] } (
         'supplied before stringifying objects',
         'supplied before stringifying objects 2',
         $fn,
         $fn2,
-      )
-    ],
-    'stringifying objects before regular values' => [ map
-      { { name => $_, rank => $rank } }
-      (
+      )),
+    ]},
+
+    'stringifying objects before regular values' => { AoA => [
+      [qw( rank name )],
+      ( map { [ $rank, $_ ] } (
         $fn,
         $fn2,
         'supplied after stringifying objects',
         'supplied after stringifying objects 2',
-      )
-    ],
-    'stringifying objects between regular values' => [ map
-      { { name => $_, rank => $rank } }
-      (
+      )),
+    ]},
+
+    'stringifying objects between regular values' => { AoA => [
+      [qw( name rank )],
+      ( map { [ $_, $rank ] } (
         'supplied before stringifying objects',
         $fn,
         $fn2,
         'supplied after stringifying objects',
-      )
-    ],
-    'stringifying objects around regular values' => [ map
-      { { name => $_, rank => $rank } }
-      (
+      ))
+    ]},
+
+    'stringifying objects around regular values' => { AoA => [
+      [qw( rank name )],
+      ( map { [ $rank, $_ ] } (
         $fn,
         'supplied between stringifying objects',
         $fn2,
-      )
-    ],
+      ))
+    ]},
+
+    'single stringifying object' => { AoA => [
+      [qw( rank name )],
+      [ $rank, $fn ],
+    ]},
   };
 
-  local $Storable::canonical = 1;
-  my $preimage = nfreeze([$fn, $fn2, $rank, $args]);
+  # generate the AoH equivalent based on the AoAs above
+  for my $bag (values %$args) {
+    my @hdr = @{$bag->{AoA}[0]};
+    for my $v ( @{$bag->{AoA}}[1..$#{$bag->{AoA}}] ) {
+      push @{$bag->{AoH}}, my $h = {};
+      @{$h}{@hdr} = @$v;
+    }
+  }
 
-  for my $tst (keys %$args) {
+  local $Storable::canonical = 1;
+  my $preimage = nfreeze($args);
 
-    # test void ctx
-    $rs->delete;
-    $rs->populate($args->{$tst});
-    is_deeply(
-      $rs->all_hri,
-      $args->{$tst},
-      "Populate() $tst in void context"
-    );
 
-    # test non-void ctx
-    $rs->delete;
-    my $dummy = $rs->populate($args->{$tst});
-    is_deeply(
-      $rs->all_hri,
-      $args->{$tst},
-      "Populate() $tst in non-void context"
-    );
+  for my $tst (keys %$args) {
+    for my $type (qw(AoA AoH)) {
+
+      # test void ctx
+      $rs->delete;
+      $rs->populate($args->{$tst}{$type});
+      is_deeply(
+        $rs->all_hri,
+        $args->{$tst}{AoH},
+        "Populate() $tst in void context"
+      );
+
+      # test scalar ctx
+      $rs->delete;
+      my $dummy = $rs->populate($args->{$tst}{$type});
+      is_deeply(
+        $rs->all_hri,
+        $args->{$tst}{AoH},
+        "Populate() $tst in non-void context"
+      );
+
+      # test list ctx
+      $rs->delete;
+      my @dummy = $rs->populate($args->{$tst}{$type});
+      is_deeply(
+        $rs->all_hri,
+        $args->{$tst}{AoH},
+        "Populate() $tst in non-void context"
+      );
+    }
 
     # test create() as we have everything set up already
     $rs->delete;
-    $rs->create($_) for @{$args->{$tst}};
+    $rs->create($_) for @{$args->{$tst}{AoH}};
 
     is_deeply(
       $rs->all_hri,
-      $args->{$tst},
+      $args->{$tst}{AoH},
       "Create() $tst"
     );
   }
 
   ok (
-    ($preimage eq nfreeze( [$fn, $fn2, $rank, $args] )),
+    ($preimage eq nfreeze($args)),
     'Arguments fed to populate()/create() unchanged'
   );
 
@@ -482,7 +511,7 @@ warnings_like {
   )
     ? ()
     # one unique for populate() and create() each
-    : (qr/\QPOSSIBLE *PAST* DATA CORRUPTION detected \E.+\QTrigger condition encountered at @{[ __FILE__ ]} line\E \d/) x 2
+    : (qr/\QPOSSIBLE *PAST* DATA CORRUPTION detected \E.+\QTrigger condition encountered at @{[ __FILE__ ]} line\E \d/) x 4
 ], 'Data integrity warnings as planned';
 
 $schema->is_executed_sql_bind(