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