X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F100populate.t;h=177231a461ba6ffddb44d33b7c1751c2d73f489f;hb=fa19e5d684ce8181f2fa2e0cd79bed14de889650;hp=822ad9379f65847bee493906c5cfd20707839221;hpb=a9bac98fc664ce08e085b230a3a8d79deee44727;p=dbsrgits%2FDBIx-Class.git

diff --git a/t/100populate.t b/t/100populate.t
index 822ad93..177231a 100644
--- a/t/100populate.t
+++ b/t/100populate.t
@@ -3,10 +3,14 @@ use warnings;
 
 use Test::More;
 use Test::Exception;
+use Test::Warn;
 use lib qw(t/lib);
 use DBICTest;
+use DBIx::Class::_Util 'sigwarn_silencer';
 use Path::Class::File ();
+use Math::BigInt;
 use List::Util qw/shuffle/;
+use Storable qw/nfreeze dclone/;
 
 my $schema = DBICTest->init_schema();
 
@@ -206,6 +210,11 @@ is($link7->title, 'gtitle', 'Link 7 title');
 my $rs = $schema->resultset('Artist');
 $rs->delete;
 throws_ok {
+    # this warning is correct, but we are not testing it here
+    # what we are after is the correct exception when an int
+    # fails to coerce into a sqlite rownum
+    local $SIG{__WARN__} = sigwarn_silencer( qr/datatype mismatch.+ foo as integer/ );
+
     $rs->populate([
         {
             artistid => 1,
@@ -220,7 +229,7 @@ throws_ok {
             name => 'foo3',
         },
     ]);
-} qr/\Qexecute_for_fetch() aborted with 'datatype mismatch\E\b/, 'bad slice';
+} qr/\Qexecute_for_fetch() aborted with 'datatype mismatch\E\b/, 'bad slice fails PK insert';
 
 is($rs->count, 0, 'populate is atomic');
 
@@ -307,82 +316,108 @@ lives_ok {
   ]);
 } 'literal+bind with semantically identical attrs works after normalization';
 
-# the stringification has nothing to do with the artist name
-# this is solely for testing consistency
-my $fn = Path::Class::File->new ('somedir/somefilename.tmp');
-my $fn2 = Path::Class::File->new ('somedir/someotherfilename.tmp');
-
-lives_ok {
-  $rs->populate([
-    {
-      name => 'supplied before stringifying object',
-    },
-    {
-      name => $fn,
-    }
-  ]);
-} 'stringifying objects pass through';
-
-# ... and vice-versa.
-
-lives_ok {
-  $rs->populate([
-    {
-      name => $fn2,
-    },
-    {
-      name => 'supplied after stringifying object',
-    },
-  ]);
-} 'stringifying objects pass through';
-
-for (
-  $fn,
-  $fn2,
-  'supplied after stringifying object',
-  'supplied before stringifying object'
-) {
-  my $row = $rs->find ({name => $_});
-  ok ($row, "Stringification test row '$_' properly inserted");
-}
-
-$rs->delete;
-
-# test stringification with ->create rather than Storage::insert_bulk as well
-
-lives_ok {
-  my @dummy = $rs->populate([
-    {
-      name => 'supplied before stringifying object',
-    },
-    {
-      name => $fn,
-    }
-  ]);
-} 'stringifying objects pass through';
+# test all kinds of population with stringified objects
+warnings_like {
+  local $ENV{DBIC_RT79576_NOWARN};
+
+  my $rs = $schema->resultset('Artist')->search({}, { columns => [qw(name rank)], order_by => 'artistid' });
+
+  # the stringification has nothing to do with the artist name
+  # this is solely for testing consistency
+  my $fn = Path::Class::File->new ('somedir/somefilename.tmp');
+  my $fn2 = Path::Class::File->new ('somedir/someotherfilename.tmp');
+  my $rank = Math::BigInt->new(42);
+
+  my $args = {
+    'stringifying objects after regular values' => [ map
+      { { name => $_, rank => $rank } }
+      (
+        'supplied before stringifying objects',
+        'supplied before stringifying objects 2',
+        $fn,
+        $fn2,
+      )
+    ],
+    'stringifying objects before regular values' => [ map
+      { { name => $_, rank => $rank } }
+      (
+        $fn,
+        $fn2,
+        'supplied after stringifying objects',
+        'supplied after stringifying objects 2',
+      )
+    ],
+    'stringifying objects between regular values' => [ map
+      { { name => $_, rank => $rank } }
+      (
+        'supplied before stringifying objects',
+        $fn,
+        $fn2,
+        'supplied after stringifying objects',
+      )
+    ],
+    'stringifying objects around regular values' => [ map
+      { { name => $_, rank => $rank } }
+      (
+        $fn,
+        'supplied between stringifying objects',
+        $fn2,
+      )
+    ],
+  };
+
+  local $Storable::canonical = 1;
+  my $preimage = nfreeze([$fn, $fn2, $rank, $args]);
+
+  for my $tst (keys %$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"
+    );
+
+    # test create() as we have everything set up already
+    $rs->delete;
+    $rs->create($_) for @{$args->{$tst}};
+
+    is_deeply(
+      $rs->all_hri,
+      $args->{$tst},
+      "Create() $tst"
+    );
+  }
 
-# ... and vice-versa.
+  ok (
+    ($preimage eq nfreeze( [$fn, $fn2, $rank, $args] )),
+    'Arguments fed to populate()/create() unchanged'
+  );
 
-lives_ok {
-  my @dummy = $rs->populate([
-    {
-      name => $fn2,
-    },
-    {
-      name => 'supplied after stringifying object',
-    },
-  ]);
-} 'stringifying objects pass through';
-
-for (
-  $fn,
-  $fn2,
-  'supplied after stringifying object',
-  'supplied before stringifying object'
-) {
-  my $row = $rs->find ({name => $_});
-  ok ($row, "Stringification test row '$_' properly inserted");
-}
+  $rs->delete;
+} [
+  # warning to be removed around Apr 1st 2015
+  # smokers start failing a month before that
+  (
+    ( DBICTest::RunMode->is_author and ( time() > 1427846400 ) )
+      or
+    ( DBICTest::RunMode->is_smoker and ( time() > 1425168000 ) )
+  )
+    ? ()
+    # one unique for populate() and create() each
+    : (qr/\QPOSSIBLE *PAST* DATA CORRUPTION detected \E.+\QTrigger condition encountered at @{[ __FILE__ ]} line\E \d/) x 2
+], 'Data integrity warnings as planned';
 
 lives_ok {
    $schema->resultset('TwoKeys')->populate([{