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

diff --git a/t/100populate.t b/t/100populate.t
index c5c3868..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();
 
@@ -154,9 +158,63 @@ is($link7->title, 'gtitle', 'Link 7 title');
   $rs->delete;
 }
 
+# populate with literal+bind
+{
+  my $rs = $schema->resultset('Link');
+  $rs->delete;
+
+  # test insert_bulk with all literal/bind sql
+  $rs->populate([
+    (+{
+        url => \['?', [ {} => 'cpan.org' ] ],
+        title => \['?', [ {} => "The 'best of' cpan" ] ],
+    }) x 5
+  ]);
+
+  is((grep {
+    $_->url eq 'cpan.org' &&
+    $_->title eq "The 'best of' cpan",
+  } $rs->all), 5, 'populate with all literal/bind');
+
+  $rs->delete;
+
+  # test insert_bulk with mix literal and literal/bind
+  $rs->populate([
+    (+{
+        url => \"'cpan.org'",
+        title => \['?', [ {} => "The 'best of' cpan" ] ],
+    }) x 5
+  ]);
+
+  is((grep {
+    $_->url eq 'cpan.org' &&
+    $_->title eq "The 'best of' cpan",
+  } $rs->all), 5, 'populate with all literal/bind SQL');
+
+  $rs->delete;
+
+  # test mixed binds with literal sql/bind
+
+  $rs->populate([ map { +{
+    url => \[ '? || ?', [ {} => 'cpan.org_' ], [ undef, $_ ] ],
+    title => "The 'best of' cpan",
+  } } (1 .. 5) ]);
+
+  for (1 .. 5) {
+    ok($rs->find({ url => "cpan.org_$_" }), "Row $_ correctly created with dynamic literal/bind populate" );
+  }
+
+  $rs->delete;
+}
+
 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,
@@ -171,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');
 
@@ -219,82 +277,147 @@ throws_ok {
   ]);
 } qr/Inconsistent literal SQL value/, 'literal sql must be the same in all slices';
 
-# 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 {
+throws_ok {
   $rs->populate([
     {
-      name => 'supplied before stringifying object',
+      artistid => 1,
+      name => \['?', [ {} => 'foo' ] ],
     },
     {
-      name => $fn,
+      artistid => 2,
+      name => \"'bar'",
     }
   ]);
-} 'stringifying objects pass through';
-
-# ... and vice-versa.
+} qr/\QIncorrect value (expecting ARRAYREF-ref/, 'literal where literal+bind expected throws';
 
-lives_ok {
+throws_ok {
   $rs->populate([
     {
-      name => $fn2,
+      artistid => 1,
+      name => \['?', [ { sqlt_datatype => 'foooo' } => 'foo' ] ],
     },
     {
-      name => 'supplied after stringifying object',
-    },
+      artistid => 2,
+      name => \['?', [ {} => 'foo' ] ],
+    }
   ]);
-} '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
+} qr/\QDiffering bind attributes on literal\/bind values not supported for column 'name'/, 'literal+bind with differing attrs throws';
 
 lives_ok {
-  my @dummy = $rs->populate([
+  $rs->populate([
     {
-      name => 'supplied before stringifying object',
+      artistid => 1,
+      name => \['?', [ undef, 'foo' ] ],
     },
     {
-      name => $fn,
+      artistid => 2,
+      name => \['?', [ {} => 'bar' ] ],
     }
   ]);
-} 'stringifying objects pass through';
-
-# ... and vice-versa.
+} 'literal+bind with semantically identical attrs works after normalization';
+
+# 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"
+    );
+  }
+
+  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([{