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