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   local $ENV{DBIC_RT79576_NOWARN};
 388
 389   my $rs = $schema->resultset('Artist')->search({}, { columns => [qw(name rank)], order_by => 'artistid' });
 390
 391   # the stringification has nothing to do with the artist name
 392   # this is solely for testing consistency
 393   my $fn = Path::Class::File->new ('somedir/somefilename.tmp');
 394   my $fn2 = Path::Class::File->new ('somedir/someotherfilename.tmp');
 395   my $rank = Math::BigInt->new(42);
 396
 397   my $args = {
 398     'stringifying objects after regular values' => { AoA => [
 399       [qw( name rank )],
 400       ( map { [ $_, $rank ] } (
 401         'supplied before stringifying objects',
 402         'supplied before stringifying objects 2',
 403         $fn,
 404         $fn2,
 405       )),
 406     ]},
 407
 408     'stringifying objects before regular values' => { AoA => [
 409       [qw( rank name )],
 410       ( map { [ $rank, $_ ] } (
 411         $fn,
 412         $fn2,
 413         'supplied after stringifying objects',
 414         'supplied after stringifying objects 2',
 415       )),
 416     ]},
 417
 418     'stringifying objects between regular values' => { AoA => [
 419       [qw( name rank )],
 420       ( map { [ $_, $rank ] } (
 421         'supplied before stringifying objects',
 422         $fn,
 423         $fn2,
 424         'supplied after stringifying objects',
 425       ))
 426     ]},
 427
 428     'stringifying objects around regular values' => { AoA => [
 429       [qw( rank name )],
 430       ( map { [ $rank, $_ ] } (
 431         $fn,
 432         'supplied between stringifying objects',
 433         $fn2,
 434       ))
 435     ]},
 436
 437     'single stringifying object' => { AoA => [
 438       [qw( rank name )],
 439       [ $rank, $fn ],
 440     ]},
 441
 442     'empty set' => { AoA => [
 443       [qw( name rank )],
 444     ]},
 445   };
 446
 447   # generate the AoH equivalent based on the AoAs above
 448   for my $bag (values %$args) {
 449     $bag->{AoH} = [];
 450     my @hdr = @{$bag->{AoA}[0]};
 451     for my $v ( @{$bag->{AoA}}[1..$#{$bag->{AoA}}] ) {
 452       push @{$bag->{AoH}}, my $h = {};
 453       @{$h}{@hdr} = @$v;
 454     }
 455   }
 456
 457   local $Storable::canonical = 1;
 458   my $preimage = serialize($args);
 459
 460
 461   for my $tst (keys %$args) {
 462     for my $type (qw(AoA AoH)) {
 463
 464       # test void ctx
 465       $rs->delete;
 466       $rs->populate($args->{$tst}{$type});
 467       is_deeply(
 468         $rs->all_hri,
 469         $args->{$tst}{AoH},
 470         "Populate() $tst in void context"
 471       );
 472
 473       # test scalar ctx
 474       $rs->delete;
 475       my $dummy = $rs->populate($args->{$tst}{$type});
 476       is_deeply(
 477         $rs->all_hri,
 478         $args->{$tst}{AoH},
 479         "Populate() $tst in non-void context"
 480       );
 481
 482       # test list ctx
 483       $rs->delete;
 484       my @dummy = $rs->populate($args->{$tst}{$type});
 485       is_deeply(
 486         $rs->all_hri,
 487         $args->{$tst}{AoH},
 488         "Populate() $tst in non-void context"
 489       );
 490     }
 491
 492     # test create() as we have everything set up already
 493     $rs->delete;
 494     $rs->create($_) for @{$args->{$tst}{AoH}};
 495
 496     is_deeply(
 497       $rs->all_hri,
 498       $args->{$tst}{AoH},
 499       "Create() $tst"
 500     );
 501   }
 502
 503   ok (
 504     ($preimage eq serialize($args)),
 505     'Arguments fed to populate()/create() unchanged'
 506   );
 507
 508   $rs->delete;
 509 } [
 510   # warning to be removed around Apr 1st 2015
 511   # smokers start failing a month before that
 512   (
 513     ( DBICTest::RunMode->is_author and ( time() > 1427846400 ) )
 514       or
 515     ( DBICTest::RunMode->is_smoker and ( time() > 1425168000 ) )
 516   )
 517     ? ()
 518     # one unique for populate() and create() each
 519     : (qr/\QPOSSIBLE *PAST* DATA CORRUPTION detected \E.+\QTrigger condition encountered at @{[ __FILE__ ]} line\E \d/) x 4
 520 ], 'Data integrity warnings as planned';
 521
 522 $schema->is_executed_sql_bind(
 523   sub {
 524    $schema->resultset('TwoKeys')->populate([{
 525       artist => 1,
 526       cd     => 5,
 527       fourkeys_to_twokeys => [{
 528             f_foo => 1,
 529             f_bar => 1,
 530             f_hello => 1,
 531             f_goodbye => 1,
 532             autopilot => 'a',
 533       },{
 534             f_foo => 2,
 535             f_bar => 2,
 536             f_hello => 2,
 537             f_goodbye => 2,
 538             autopilot => 'b',
 539       }]
 540    }])
 541   },
 542   [
 543     [ 'BEGIN' ],
 544     [ 'INSERT INTO twokeys ( artist, cd)
 545         VALUES ( ?, ? )',
 546       '__BULK_INSERT__'
 547     ],
 548     [ 'INSERT INTO fourkeys_to_twokeys ( autopilot, f_bar, f_foo, f_goodbye, f_hello, t_artist, t_cd)
 549         VALUES (
 550           ?, ?, ?, ?, ?,
 551           ( SELECT me.artist FROM twokeys me WHERE artist = ? AND cd = ? ),
 552           ( SELECT me.cd FROM twokeys me WHERE artist = ? AND cd = ? )
 553         )
 554       ',
 555       '__BULK_INSERT__'
 556     ],
 557     [ 'COMMIT' ],
 558   ],
 559   'multicol-PK has_many populate expected trace'
 560 );
 561
 562 lives_ok ( sub {
 563   $schema->populate('CD', [
 564     {cdid => 10001, artist => $artist->id, title => 'Pretty Much Empty', year => 2011, tracks => []},
 565   ])
 566 }, 'empty has_many relationship accepted by populate');
 567
 568 done_testing;