t/100populate.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More;
   5 use Test::Exception;
   6 use Test::Warn;
   7 use lib qw(t/lib);
   8 use DBICTest;
   9 use DBIx::Class::_Util qw(sigwarn_silencer serialize);
  10 use Path::Class::File ();
  11 use Math::BigInt;
  12 use List::Util qw/shuffle/;
  13
  14 my $schema = DBICTest->init_schema();
  15
  16 # The map below generates stuff like:
  17 #   [ qw/artistid name/ ],
  18 #   [ 4, "b" ],
  19 #   [ 5, "c" ],
  20 #   ...
  21 #   [ 9999, "ntm" ],
  22 #   [ 10000, "ntn" ],
  23
  24 my $start_id = 'populateXaaaaaa';
  25 my $rows = 10_000;
  26 my $offset = 3;
  27
  28 $schema->populate('Artist', [ [ qw/artistid name/ ], map { [ ($_ + $offset) => $start_id++ ] } shuffle ( 1 .. $rows ) ] );
  29 is (
  30     $schema->resultset ('Artist')->search ({ name => { -like => 'populateX%' } })->count,
  31     $rows,
  32     'populate created correct number of rows with massive AoA bulk insert',
  33 );
  34
  35 my $artist = $schema->resultset ('Artist')
  36               ->search ({ 'cds.title' => { '!=', undef } }, { join => 'cds' })
  37                 ->first;
  38 my $ex_title = $artist->cds->first->title;
  39
  40 throws_ok ( sub {
  41   my $i = 600;
  42   $schema->populate('CD', [
  43     map {
  44       {
  45         artist => $artist->id,
  46         title => $_,
  47         year => 2009,
  48       }
  49     } ('Huey', 'Dewey', $ex_title, 'Louie')
  50   ])
  51 }, qr/\Qexecute_for_fetch() aborted with '\E.+ at populate slice.+$ex_title/ms, 'Readable exception thrown for failed populate');
  52
  53 ## make sure populate honors fields/orders in list context
  54 ## schema order
  55 my @links = $schema->populate('Link', [
  56 [ qw/id url title/ ],
  57 [ qw/2 burl btitle/ ]
  58 ]);
  59 is(scalar @links, 1);
  60
  61 my $link2 = shift @links;
  62 is($link2->id, 2, 'Link 2 id');
  63 is($link2->url, 'burl', 'Link 2 url');
  64 is($link2->title, 'btitle', 'Link 2 title');
  65
  66 ## non-schema order
  67 @links = $schema->populate('Link', [
  68 [ qw/id title url/ ],
  69 [ qw/3 ctitle curl/ ]
  70 ]);
  71 is(scalar @links, 1);
  72
  73 my $link3 = shift @links;
  74 is($link3->id, 3, 'Link 3 id');
  75 is($link3->url, 'curl', 'Link 3 url');
  76 is($link3->title, 'ctitle', 'Link 3 title');
  77
  78 ## not all physical columns
  79 @links = $schema->populate('Link', [
  80 [ qw/id title/ ],
  81 [ qw/4 dtitle/ ]
  82 ]);
  83 is(scalar @links, 1);
  84
  85 my $link4 = shift @links;
  86 is($link4->id, 4, 'Link 4 id');
  87 is($link4->url, undef, 'Link 4 url');
  88 is($link4->title, 'dtitle', 'Link 4 title');
  89
  90 ## variable size dataset
  91 @links = $schema->populate('Link', [
  92 [ qw/id title url/ ],
  93 [ 41 ],
  94 [ 42, undef, 'url42' ],
  95 ]);
  96 is(scalar @links, 2);
  97 is($links[0]->url, undef);
  98 is($links[1]->url, 'url42');
  99
 100 ## make sure populate -> _insert_bulk honors fields/orders in void context
 101 ## schema order
 102 $schema->populate('Link', [
 103 [ qw/id url title/ ],
 104 [ qw/5 eurl etitle/ ]
 105 ]);
 106 my $link5 = $schema->resultset('Link')->find(5);
 107 is($link5->id, 5, 'Link 5 id');
 108 is($link5->url, 'eurl', 'Link 5 url');
 109 is($link5->title, 'etitle', 'Link 5 title');
 110
 111 ## non-schema order
 112 $schema->populate('Link', [
 113 [ qw/id title url/ ],
 114 [ qw/6 ftitle furl/ ]
 115 ]);
 116 my $link6 = $schema->resultset('Link')->find(6);
 117 is($link6->id, 6, 'Link 6 id');
 118 is($link6->url, 'furl', 'Link 6 url');
 119 is($link6->title, 'ftitle', 'Link 6 title');
 120
 121 ## not all physical columns
 122 $schema->populate('Link', [
 123 [ qw/id title/ ],
 124 [ qw/7 gtitle/ ]
 125 ]);
 126 my $link7 = $schema->resultset('Link')->find(7);
 127 is($link7->id, 7, 'Link 7 id');
 128 is($link7->url, undef, 'Link 7 url');
 129 is($link7->title, 'gtitle', 'Link 7 title');
 130
 131 ## variable size dataset in void ctx
 132 $schema->populate('Link', [
 133 [ qw/id title url/ ],
 134 [ 71 ],
 135 [ 72, undef, 'url72' ],
 136 ]);
 137 @links = $schema->resultset('Link')->search({ id => [71, 72]}, { order_by => 'id' })->all;
 138 is(scalar @links, 2);
 139 is($links[0]->url, undef);
 140 is($links[1]->url, 'url72');
 141
 142 ## variable size dataset in void ctx, hash version
 143 $schema->populate('Link', [
 144   { id => 73 },
 145   { id => 74, title => 't74' },
 146   { id => 75, url => 'u75' },
 147 ]);
 148 @links = $schema->resultset('Link')->search({ id => [73..75]}, { order_by => 'id' })->all;
 149 is(scalar @links, 3);
 150 is($links[0]->url, undef);
 151 is($links[0]->title, undef);
 152 is($links[1]->url, undef);
 153 is($links[1]->title, 't74');
 154 is($links[2]->url, 'u75');
 155 is($links[2]->title, undef);
 156
 157 ## Make sure the void ctx trace is sane
 158 {
 159   for (
 160     [
 161       [ qw/id title url/ ],
 162       [ 81 ],
 163       [ 82, 't82' ],
 164       [ 83, undef, 'url83' ],
 165     ],
 166     [
 167       { id => 91 },
 168       { id => 92, title => 't92' },
 169       { id => 93, url => 'url93' },
 170     ]
 171   ) {
 172     $schema->is_executed_sql_bind(
 173       sub {
 174         $schema->populate('Link', $_);
 175       },
 176       [
 177         [ 'BEGIN' ],
 178         [
 179           'INSERT INTO link( id, title, url ) VALUES( ?, ?, ? )',
 180           "__BULK_INSERT__"
 181         ],
 182         [ 'COMMIT' ],
 183       ]
 184     );
 185   }
 186 }
 187
 188 # populate with literals
 189 {
 190   my $rs = $schema->resultset('Link');
 191   $rs->delete;
 192
 193   # test populate with all literal sql (no binds)
 194
 195   $rs->populate([
 196     (+{
 197         url => \"'cpan.org'",
 198         title => \"'The ''best of'' cpan'",
 199     }) x 5
 200   ]);
 201
 202   is((grep {
 203     $_->url eq 'cpan.org' &&
 204     $_->title eq "The 'best of' cpan",
 205   } $rs->all), 5, 'populate with all literal SQL');
 206
 207   $rs->delete;
 208
 209   # test mixed binds with literal sql
 210
 211   $rs->populate([
 212     (+{
 213         url => \"'cpan.org'",
 214         title => "The 'best of' cpan",
 215     }) x 5
 216   ]);
 217
 218   is((grep {
 219     $_->url eq 'cpan.org' &&
 220     $_->title eq "The 'best of' cpan",
 221   } $rs->all), 5, 'populate with all literal SQL');
 222
 223   $rs->delete;
 224 }
 225
 226 # populate with literal+bind
 227 {
 228   my $rs = $schema->resultset('Link');
 229   $rs->delete;
 230
 231   # test populate with all literal/bind sql
 232   $rs->populate([
 233     (+{
 234         url => \['?', [ {} => 'cpan.org' ] ],
 235         title => \['?', [ {} => "The 'best of' cpan" ] ],
 236     }) x 5
 237   ]);
 238
 239   is((grep {
 240     $_->url eq 'cpan.org' &&
 241     $_->title eq "The 'best of' cpan",
 242   } $rs->all), 5, 'populate with all literal/bind');
 243
 244   $rs->delete;
 245
 246   # test populate with mix literal and literal/bind
 247   $rs->populate([
 248     (+{
 249         url => \"'cpan.org'",
 250         title => \['?', [ {} => "The 'best of' cpan" ] ],
 251     }) x 5
 252   ]);
 253
 254   is((grep {
 255     $_->url eq 'cpan.org' &&
 256     $_->title eq "The 'best of' cpan",
 257   } $rs->all), 5, 'populate with all literal/bind SQL');
 258
 259   $rs->delete;
 260
 261   # test mixed binds with literal sql/bind
 262
 263   $rs->populate([ map { +{
 264     url => \[ '? || ?', [ {} => 'cpan.org_' ], $_ ],
 265     title => "The 'best of' cpan",
 266   } } (1 .. 5) ]);
 267
 268   for (1 .. 5) {
 269     ok($rs->find({ url => "cpan.org_$_" }), "Row $_ correctly created with dynamic literal/bind populate" );
 270   }
 271
 272   $rs->delete;
 273 }
 274
 275 my $rs = $schema->resultset('Artist');
 276 $rs->delete;
 277 throws_ok {
 278     # this warning is correct, but we are not testing it here
 279     # what we are after is the correct exception when an int
 280     # fails to coerce into a sqlite rownum
 281     local $SIG{__WARN__} = sigwarn_silencer( qr/datatype mismatch.+ foo as integer/ );
 282
 283     $rs->populate([
 284         {
 285             artistid => 1,
 286             name => 'foo1',
 287         },
 288         {
 289             artistid => 'foo', # this dies
 290             name => 'foo2',
 291         },
 292         {
 293             artistid => 3,
 294             name => 'foo3',
 295         },
 296     ]);
 297 } qr/\Qexecute_for_fetch() aborted with 'datatype mismatch\E\b/, 'bad slice fails PK insert';
 298
 299 is($rs->count, 0, 'populate is atomic');
 300
 301 # Trying to use a column marked as a bind in the first slice with literal sql in
 302 # a later slice should throw.
 303
 304 throws_ok {
 305   $rs->populate([
 306     {
 307       artistid => 1,
 308       name => \"'foo'",
 309     },
 310     {
 311       artistid => \2,
 312       name => \"'foo'",
 313     }
 314   ]);
 315 } qr/Literal SQL found where a plain bind value is expected/, 'literal sql where bind expected throws';
 316
 317 # ... and vice-versa.
 318
 319 throws_ok {
 320   $rs->populate([
 321     {
 322       artistid => \1,
 323       name => \"'foo'",
 324     },
 325     {
 326       artistid => 2,
 327       name => \"'foo'",
 328     }
 329   ]);
 330 } qr/\QIncorrect value (expecting SCALAR-ref/, 'bind where literal sql expected throws';
 331
 332 throws_ok {
 333   $rs->populate([
 334     {
 335       artistid => 1,
 336       name => \"'foo'",
 337     },
 338     {
 339       artistid => 2,
 340       name => \"'bar'",
 341     }
 342   ]);
 343 } qr/Inconsistent literal SQL value/, 'literal sql must be the same in all slices';
 344
 345 throws_ok {
 346   $rs->populate([
 347     {
 348       artistid => 1,
 349       name => \['?', [ {} => 'foo' ] ],
 350     },
 351     {
 352       artistid => 2,
 353       name => \"'bar'",
 354     }
 355   ]);
 356 } qr/\QIncorrect value (expecting ARRAYREF-ref/, 'literal where literal+bind expected throws';
 357
 358 throws_ok {
 359   $rs->populate([
 360     {
 361       artistid => 1,
 362       name => \['?', [ { sqlt_datatype => 'foooo' } => 'foo' ] ],
 363     },
 364     {
 365       artistid => 2,
 366       name => \['?', [ {} => 'foo' ] ],
 367     }
 368   ]);
 369 } qr/\QDiffering bind attributes on literal\/bind values not supported for column 'name'/, 'literal+bind with differing attrs throws';
 370
 371 lives_ok {
 372   $rs->populate([
 373     {
 374       artistid => 1,
 375       name => \['?', [ undef, 'foo' ] ],
 376     },
 377     {
 378       artistid => 2,
 379       name => \['?', [ {} => 'bar' ] ],
 380     }
 381   ]);
 382 } 'literal+bind with semantically identical attrs works after normalization';
 383
 384 # test all kinds of population with stringified objects
 385 # or with empty sets
 386 warnings_like {
 387   my $rs = $schema->resultset('Artist')->search({}, { columns => [qw(name rank)], order_by => 'artistid' });
 388
 389   # the stringification has nothing to do with the artist name
 390   # this is solely for testing consistency
 391   my $fn = Path::Class::File->new ('somedir/somefilename.tmp');
 392   my $fn2 = Path::Class::File->new ('somedir/someotherfilename.tmp');
 393   my $rank = Math::BigInt->new(42);
 394
 395   my $args = {
 396     'stringifying objects after regular values' => { AoA => [
 397       [qw( name rank )],
 398       ( map { [ $_, $rank ] } (
 399         'supplied before stringifying objects',
 400         'supplied before stringifying objects 2',
 401         $fn,
 402         $fn2,
 403       )),
 404     ]},
 405
 406     'stringifying objects before regular values' => { AoA => [
 407       [qw( rank name )],
 408       ( map { [ $rank, $_ ] } (
 409         $fn,
 410         $fn2,
 411         'supplied after stringifying objects',
 412         'supplied after stringifying objects 2',
 413       )),
 414     ]},
 415
 416     'stringifying objects between regular values' => { AoA => [
 417       [qw( name rank )],
 418       ( map { [ $_, $rank ] } (
 419         'supplied before stringifying objects',
 420         $fn,
 421         $fn2,
 422         'supplied after stringifying objects',
 423       ))
 424     ]},
 425
 426     'stringifying objects around regular values' => { AoA => [
 427       [qw( rank name )],
 428       ( map { [ $rank, $_ ] } (
 429         $fn,
 430         'supplied between stringifying objects',
 431         $fn2,
 432       ))
 433     ]},
 434
 435     'single stringifying object' => { AoA => [
 436       [qw( rank name )],
 437       [ $rank, $fn ],
 438     ]},
 439
 440     'empty set' => { AoA => [
 441       [qw( name rank )],
 442     ]},
 443   };
 444
 445   # generate the AoH equivalent based on the AoAs above
 446   for my $bag (values %$args) {
 447     $bag->{AoH} = [];
 448     my @hdr = @{$bag->{AoA}[0]};
 449     for my $v ( @{$bag->{AoA}}[1..$#{$bag->{AoA}}] ) {
 450       push @{$bag->{AoH}}, my $h = {};
 451       @{$h}{@hdr} = @$v;
 452     }
 453   }
 454
 455   local $Storable::canonical = 1;
 456   my $preimage = serialize($args);
 457
 458
 459   for my $tst (keys %$args) {
 460     for my $type (qw(AoA AoH)) {
 461
 462       # test void ctx
 463       $rs->delete;
 464       $rs->populate($args->{$tst}{$type});
 465       is_deeply(
 466         $rs->all_hri,
 467         $args->{$tst}{AoH},
 468         "Populate() $tst in void context"
 469       );
 470
 471       # test scalar ctx
 472       $rs->delete;
 473       my $dummy = $rs->populate($args->{$tst}{$type});
 474       is_deeply(
 475         $rs->all_hri,
 476         $args->{$tst}{AoH},
 477         "Populate() $tst in non-void context"
 478       );
 479
 480       # test list ctx
 481       $rs->delete;
 482       my @dummy = $rs->populate($args->{$tst}{$type});
 483       is_deeply(
 484         $rs->all_hri,
 485         $args->{$tst}{AoH},
 486         "Populate() $tst in non-void context"
 487       );
 488     }
 489
 490     # test create() as we have everything set up already
 491     $rs->delete;
 492     $rs->create($_) for @{$args->{$tst}{AoH}};
 493
 494     is_deeply(
 495       $rs->all_hri,
 496       $args->{$tst}{AoH},
 497       "Create() $tst"
 498     );
 499   }
 500
 501   ok (
 502     ($preimage eq serialize($args)),
 503     'Arguments fed to populate()/create() unchanged'
 504   );
 505
 506   $rs->delete;
 507 } [], 'Data integrity warnings gone as planned';
 508
 509 $schema->is_executed_sql_bind(
 510   sub {
 511    $schema->resultset('TwoKeys')->populate([{
 512       artist => 1,
 513       cd     => 5,
 514       fourkeys_to_twokeys => [{
 515             f_foo => 1,
 516             f_bar => 1,
 517             f_hello => 1,
 518             f_goodbye => 1,
 519             autopilot => 'a',
 520       },{
 521             f_foo => 2,
 522             f_bar => 2,
 523             f_hello => 2,
 524             f_goodbye => 2,
 525             autopilot => 'b',
 526       }]
 527    }])
 528   },
 529   [
 530     [ 'BEGIN' ],
 531     [ 'INSERT INTO twokeys ( artist, cd)
 532         VALUES ( ?, ? )',
 533       '__BULK_INSERT__'
 534     ],
 535     [ 'INSERT INTO fourkeys_to_twokeys ( autopilot, f_bar, f_foo, f_goodbye, f_hello, t_artist, t_cd)
 536         VALUES (
 537           ?, ?, ?, ?, ?,
 538           ( SELECT me.artist FROM twokeys me WHERE artist = ? AND cd = ? ),
 539           ( SELECT me.cd FROM twokeys me WHERE artist = ? AND cd = ? )
 540         )
 541       ',
 542       '__BULK_INSERT__'
 543     ],
 544     [ 'COMMIT' ],
 545   ],
 546   'multicol-PK has_many populate expected trace'
 547 );
 548
 549 lives_ok ( sub {
 550   $schema->populate('CD', [
 551     {cdid => 10001, artist => $artist->id, title => 'Pretty Much Empty', year => 2011, tracks => []},
 552   ])
 553 }, 'empty has_many relationship accepted by populate');
 554
 555 done_testing;