t/100populate.t

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