X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F100populate.t;h=2817e5b2b84eedcf1b6447bd6a7e6e871d042e31;hb=HEAD;hp=b6ea7d9470857f293e760321497809b5acd881d5;hpb=75a1d824dae50a309db204be15ef46aa52b1deb5;p=dbsrgits%2FDBIx-Class.git

diff --git a/t/100populate.t b/t/100populate.t
index b6ea7d9..2817e5b 100644
--- a/t/100populate.t
+++ b/t/100populate.t
@@ -1,15 +1,30 @@
+BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
+
 use strict;
 use warnings;
 
 use Test::More;
 use Test::Exception;
 use Test::Warn;
-use lib qw(t/lib);
+
 use DBICTest;
-use Path::Class::File ();
+use DBIx::Class::_Util qw(sigwarn_silencer serialize);
 use Math::BigInt;
 use List::Util qw/shuffle/;
-use Storable qw/nfreeze dclone/;
+
+{
+  package DBICTest::StringifiesOnly;
+  use overload
+    '""' => sub { $_[0]->[0] },
+    fallback => 0,
+  ;
+}
+{
+  package DBICTest::StringifiesViaFallback;
+  use overload
+    'bool' => sub { $_[0]->[0] },
+  ;
+}
 
 my $schema = DBICTest->init_schema();
 
@@ -87,8 +102,17 @@ is($link4->id, 4, 'Link 4 id');
 is($link4->url, undef, 'Link 4 url');
 is($link4->title, 'dtitle', 'Link 4 title');
 
+## variable size dataset
+@links = $schema->populate('Link', [
+[ qw/id title url/ ],
+[ 41 ],
+[ 42, undef, 'url42' ],
+]);
+is(scalar @links, 2);
+is($links[0]->url, undef);
+is($links[1]->url, 'url42');
 
-## make sure populate -> insert_bulk honors fields/orders in void context
+## make sure populate -> _insert_bulk honors fields/orders in void context
 ## schema order
 $schema->populate('Link', [
 [ qw/id url title/ ],
@@ -119,12 +143,69 @@ is($link7->id, 7, 'Link 7 id');
 is($link7->url, undef, 'Link 7 url');
 is($link7->title, 'gtitle', 'Link 7 title');
 
+## variable size dataset in void ctx
+$schema->populate('Link', [
+[ qw/id title url/ ],
+[ 71 ],
+[ 72, undef, 'url72' ],
+]);
+@links = $schema->resultset('Link')->search({ id => [71, 72]}, { order_by => 'id' })->all;
+is(scalar @links, 2);
+is($links[0]->url, undef);
+is($links[1]->url, 'url72');
+
+## variable size dataset in void ctx, hash version
+$schema->populate('Link', [
+  { id => 73 },
+  { id => 74, title => 't74' },
+  { id => 75, url => 'u75' },
+]);
+@links = $schema->resultset('Link')->search({ id => [73..75]}, { order_by => 'id' })->all;
+is(scalar @links, 3);
+is($links[0]->url, undef);
+is($links[0]->title, undef);
+is($links[1]->url, undef);
+is($links[1]->title, 't74');
+is($links[2]->url, 'u75');
+is($links[2]->title, undef);
+
+## Make sure the void ctx trace is sane
+{
+  for (
+    [
+      [ qw/id title url/ ],
+      [ 81 ],
+      [ 82, 't82' ],
+      [ 83, undef, 'url83' ],
+    ],
+    [
+      { id => 91 },
+      { id => 92, title => 't92' },
+      { id => 93, url => 'url93' },
+    ]
+  ) {
+    $schema->is_executed_sql_bind(
+      sub {
+        $schema->populate('Link', $_);
+      },
+      [
+        [ 'BEGIN' ],
+        [
+          'INSERT INTO link( id, title, url ) VALUES( ?, ?, ? )',
+          "__BULK_INSERT__"
+        ],
+        [ 'COMMIT' ],
+      ]
+    );
+  }
+}
+
 # populate with literals
 {
   my $rs = $schema->resultset('Link');
   $rs->delete;
 
-  # test insert_bulk with all literal sql (no binds)
+  # test populate with all literal sql (no binds)
 
   $rs->populate([
     (+{
@@ -162,7 +243,7 @@ is($link7->title, 'gtitle', 'Link 7 title');
   my $rs = $schema->resultset('Link');
   $rs->delete;
 
-  # test insert_bulk with all literal/bind sql
+  # test populate with all literal/bind sql
   $rs->populate([
     (+{
         url => \['?', [ {} => 'cpan.org' ] ],
@@ -177,7 +258,7 @@ is($link7->title, 'gtitle', 'Link 7 title');
 
   $rs->delete;
 
-  # test insert_bulk with mix literal and literal/bind
+  # test populate with mix literal and literal/bind
   $rs->populate([
     (+{
         url => \"'cpan.org'",
@@ -195,7 +276,7 @@ is($link7->title, 'gtitle', 'Link 7 title');
   # test mixed binds with literal sql/bind
 
   $rs->populate([ map { +{
-    url => \[ '? || ?', [ {} => 'cpan.org_' ], [ undef, $_ ] ],
+    url => \[ '? || ?', [ {} => 'cpan.org_' ], $_ ],
     title => "The 'best of' cpan",
   } } (1 .. 5) ]);
 
@@ -209,6 +290,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,
@@ -223,7 +309,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');
 
@@ -311,107 +397,137 @@ lives_ok {
 } 'literal+bind with semantically identical attrs works after normalization';
 
 # test all kinds of population with stringified objects
+# or with empty sets
 warnings_like {
   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 $fn = bless [ 'somedir/somefilename.tmp' ], 'DBICTest::StringifiesOnly';
+  my $fn2 = bless [ 'somedir/someotherfilename.tmp' ], 'DBICTest::StringifiesViaFallback';
   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 ],
+    ]},
+
+    'empty set' => { AoA => [
+      [qw( name rank )],
+    ]},
   };
 
+  # generate the AoH equivalent based on the AoAs above
+  # also generate the expected HRI output ( is_deeply is too smart for its own good )
+  for my $bag (values %$args) {
+    $bag->{AoH} = [];
+    $bag->{Expected} = [];
+    my @hdr = @{$bag->{AoA}[0]};
+    for my $v ( @{$bag->{AoA}}[1..$#{$bag->{AoA}}] ) {
+      push @{$bag->{AoH}}, my $h = {};
+      @{$h}{@hdr} = @$v;
+
+      push @{$bag->{Expected}}, my $hs = {};
+      @{$hs}{@hdr} = map { "$_" } @$v;
+    }
+  }
+
   local $Storable::canonical = 1;
-  my $preimage = nfreeze([$fn, $fn2, $rank, $args]);
+  my $preimage = serialize($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"
-    );
+  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}{Expected},
+        "Populate() $tst in void context"
+      );
+
+      # test scalar ctx
+      $rs->delete;
+      my $dummy = $rs->populate($args->{$tst}{$type});
+      is_deeply(
+        $rs->all_hri,
+        $args->{$tst}{Expected},
+        "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}{Expected},
+        "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}{Expected},
       "Create() $tst"
     );
   }
 
   ok (
-    ($preimage eq nfreeze( [$fn, $fn2, $rank, $args] )),
+    ($preimage eq serialize($args)),
     'Arguments fed to populate()/create() unchanged'
   );
 
   $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';
+} [], 'Data integrity warnings gone as planned';
 
-lives_ok {
+$schema->is_executed_sql_bind(
+  sub {
    $schema->resultset('TwoKeys')->populate([{
       artist => 1,
       cd     => 5,
@@ -429,7 +545,26 @@ lives_ok {
             autopilot => 'b',
       }]
    }])
-} 'multicol-PK has_many populate works';
+  },
+  [
+    [ 'BEGIN' ],
+    [ 'INSERT INTO twokeys ( artist, cd)
+        VALUES ( ?, ? )',
+      '__BULK_INSERT__'
+    ],
+    [ 'INSERT INTO fourkeys_to_twokeys ( autopilot, f_bar, f_foo, f_goodbye, f_hello, t_artist, t_cd)
+        VALUES (
+          ?, ?, ?, ?, ?,
+          ( SELECT me.artist FROM twokeys me WHERE artist = ? AND cd = ? ),
+          ( SELECT me.cd FROM twokeys me WHERE artist = ? AND cd = ? )
+        )
+      ',
+      '__BULK_INSERT__'
+    ],
+    [ 'COMMIT' ],
+  ],
+  'multicol-PK has_many populate expected trace'
+);
 
 lives_ok ( sub {
   $schema->populate('CD', [