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
  92 ## make sure populate -> insert_bulk honors fields/orders in void context
  93 ## schema order
  94 $schema->populate('Link', [
  95 [ qw/id url title/ ],
  96 [ qw/5 eurl etitle/ ]
  97 ]);
  98 my $link5 = $schema->resultset('Link')->find(5);
  99 is($link5->id, 5, 'Link 5 id');
 100 is($link5->url, 'eurl', 'Link 5 url');
 101 is($link5->title, 'etitle', 'Link 5 title');
 102
 103 ## non-schema order
 104 $schema->populate('Link', [
 105 [ qw/id title url/ ],
 106 [ qw/6 ftitle furl/ ]
 107 ]);
 108 my $link6 = $schema->resultset('Link')->find(6);
 109 is($link6->id, 6, 'Link 6 id');
 110 is($link6->url, 'furl', 'Link 6 url');
 111 is($link6->title, 'ftitle', 'Link 6 title');
 112
 113 ## not all physical columns
 114 $schema->populate('Link', [
 115 [ qw/id title/ ],
 116 [ qw/7 gtitle/ ]
 117 ]);
 118 my $link7 = $schema->resultset('Link')->find(7);
 119 is($link7->id, 7, 'Link 7 id');
 120 is($link7->url, undef, 'Link 7 url');
 121 is($link7->title, 'gtitle', 'Link 7 title');
 122
 123 # populate with literals
 124 {
 125   my $rs = $schema->resultset('Link');
 126   $rs->delete;
 127
 128   # test insert_bulk with all literal sql (no binds)
 129
 130   $rs->populate([
 131     (+{
 132         url => \"'cpan.org'",
 133         title => \"'The ''best of'' cpan'",
 134     }) x 5
 135   ]);
 136
 137   is((grep {
 138     $_->url eq 'cpan.org' &&
 139     $_->title eq "The 'best of' cpan",
 140   } $rs->all), 5, 'populate with all literal SQL');
 141
 142   $rs->delete;
 143
 144   # test mixed binds with literal sql
 145
 146   $rs->populate([
 147     (+{
 148         url => \"'cpan.org'",
 149         title => "The 'best of' cpan",
 150     }) x 5
 151   ]);
 152
 153   is((grep {
 154     $_->url eq 'cpan.org' &&
 155     $_->title eq "The 'best of' cpan",
 156   } $rs->all), 5, 'populate with all literal SQL');
 157
 158   $rs->delete;
 159 }
 160
 161 # populate with literal+bind
 162 {
 163   my $rs = $schema->resultset('Link');
 164   $rs->delete;
 165
 166   # test insert_bulk with all literal/bind sql
 167   $rs->populate([
 168     (+{
 169         url => \['?', [ {} => 'cpan.org' ] ],
 170         title => \['?', [ {} => "The 'best of' cpan" ] ],
 171     }) x 5
 172   ]);
 173
 174   is((grep {
 175     $_->url eq 'cpan.org' &&
 176     $_->title eq "The 'best of' cpan",
 177   } $rs->all), 5, 'populate with all literal/bind');
 178
 179   $rs->delete;
 180
 181   # test insert_bulk with mix literal and literal/bind
 182   $rs->populate([
 183     (+{
 184         url => \"'cpan.org'",
 185         title => \['?', [ {} => "The 'best of' cpan" ] ],
 186     }) x 5
 187   ]);
 188
 189   is((grep {
 190     $_->url eq 'cpan.org' &&
 191     $_->title eq "The 'best of' cpan",
 192   } $rs->all), 5, 'populate with all literal/bind SQL');
 193
 194   $rs->delete;
 195
 196   # test mixed binds with literal sql/bind
 197
 198   $rs->populate([ map { +{
 199     url => \[ '? || ?', [ {} => 'cpan.org_' ], $_ ],
 200     title => "The 'best of' cpan",
 201   } } (1 .. 5) ]);
 202
 203   for (1 .. 5) {
 204     ok($rs->find({ url => "cpan.org_$_" }), "Row $_ correctly created with dynamic literal/bind populate" );
 205   }
 206
 207   $rs->delete;
 208 }
 209
 210 my $rs = $schema->resultset('Artist');
 211 $rs->delete;
 212 throws_ok {
 213     # this warning is correct, but we are not testing it here
 214     # what we are after is the correct exception when an int
 215     # fails to coerce into a sqlite rownum
 216     local $SIG{__WARN__} = sigwarn_silencer( qr/datatype mismatch.+ foo as integer/ );
 217
 218     $rs->populate([
 219         {
 220             artistid => 1,
 221             name => 'foo1',
 222         },
 223         {
 224             artistid => 'foo', # this dies
 225             name => 'foo2',
 226         },
 227         {
 228             artistid => 3,
 229             name => 'foo3',
 230         },
 231     ]);
 232 } qr/\Qexecute_for_fetch() aborted with 'datatype mismatch\E\b/, 'bad slice fails PK insert';
 233
 234 is($rs->count, 0, 'populate is atomic');
 235
 236 # Trying to use a column marked as a bind in the first slice with literal sql in
 237 # a later slice should throw.
 238
 239 throws_ok {
 240   $rs->populate([
 241     {
 242       artistid => 1,
 243       name => \"'foo'",
 244     },
 245     {
 246       artistid => \2,
 247       name => \"'foo'",
 248     }
 249   ]);
 250 } qr/Literal SQL found where a plain bind value is expected/, 'literal sql where bind expected throws';
 251
 252 # ... and vice-versa.
 253
 254 throws_ok {
 255   $rs->populate([
 256     {
 257       artistid => \1,
 258       name => \"'foo'",
 259     },
 260     {
 261       artistid => 2,
 262       name => \"'foo'",
 263     }
 264   ]);
 265 } qr/\QIncorrect value (expecting SCALAR-ref/, 'bind where literal sql expected throws';
 266
 267 throws_ok {
 268   $rs->populate([
 269     {
 270       artistid => 1,
 271       name => \"'foo'",
 272     },
 273     {
 274       artistid => 2,
 275       name => \"'bar'",
 276     }
 277   ]);
 278 } qr/Inconsistent literal SQL value/, 'literal sql must be the same in all slices';
 279
 280 throws_ok {
 281   $rs->populate([
 282     {
 283       artistid => 1,
 284       name => \['?', [ {} => 'foo' ] ],
 285     },
 286     {
 287       artistid => 2,
 288       name => \"'bar'",
 289     }
 290   ]);
 291 } qr/\QIncorrect value (expecting ARRAYREF-ref/, 'literal where literal+bind expected throws';
 292
 293 throws_ok {
 294   $rs->populate([
 295     {
 296       artistid => 1,
 297       name => \['?', [ { sqlt_datatype => 'foooo' } => 'foo' ] ],
 298     },
 299     {
 300       artistid => 2,
 301       name => \['?', [ {} => 'foo' ] ],
 302     }
 303   ]);
 304 } qr/\QDiffering bind attributes on literal\/bind values not supported for column 'name'/, 'literal+bind with differing attrs throws';
 305
 306 lives_ok {
 307   $rs->populate([
 308     {
 309       artistid => 1,
 310       name => \['?', [ undef, 'foo' ] ],
 311     },
 312     {
 313       artistid => 2,
 314       name => \['?', [ {} => 'bar' ] ],
 315     }
 316   ]);
 317 } 'literal+bind with semantically identical attrs works after normalization';
 318
 319 # test all kinds of population with stringified objects
 320 warnings_like {
 321   local $ENV{DBIC_RT79576_NOWARN};
 322
 323   my $rs = $schema->resultset('Artist')->search({}, { columns => [qw(name rank)], order_by => 'artistid' });
 324
 325   # the stringification has nothing to do with the artist name
 326   # this is solely for testing consistency
 327   my $fn = Path::Class::File->new ('somedir/somefilename.tmp');
 328   my $fn2 = Path::Class::File->new ('somedir/someotherfilename.tmp');
 329   my $rank = Math::BigInt->new(42);
 330
 331   my $args = {
 332     'stringifying objects after regular values' => [ map
 333       { { name => $_, rank => $rank } }
 334       (
 335         'supplied before stringifying objects',
 336         'supplied before stringifying objects 2',
 337         $fn,
 338         $fn2,
 339       )
 340     ],
 341     'stringifying objects before regular values' => [ map
 342       { { name => $_, rank => $rank } }
 343       (
 344         $fn,
 345         $fn2,
 346         'supplied after stringifying objects',
 347         'supplied after stringifying objects 2',
 348       )
 349     ],
 350     'stringifying objects between regular values' => [ map
 351       { { name => $_, rank => $rank } }
 352       (
 353         'supplied before stringifying objects',
 354         $fn,
 355         $fn2,
 356         'supplied after stringifying objects',
 357       )
 358     ],
 359     'stringifying objects around regular values' => [ map
 360       { { name => $_, rank => $rank } }
 361       (
 362         $fn,
 363         'supplied between stringifying objects',
 364         $fn2,
 365       )
 366     ],
 367   };
 368
 369   local $Storable::canonical = 1;
 370   my $preimage = nfreeze([$fn, $fn2, $rank, $args]);
 371
 372   for my $tst (keys %$args) {
 373
 374     # test void ctx
 375     $rs->delete;
 376     $rs->populate($args->{$tst});
 377     is_deeply(
 378       $rs->all_hri,
 379       $args->{$tst},
 380       "Populate() $tst in void context"
 381     );
 382
 383     # test non-void ctx
 384     $rs->delete;
 385     my $dummy = $rs->populate($args->{$tst});
 386     is_deeply(
 387       $rs->all_hri,
 388       $args->{$tst},
 389       "Populate() $tst in non-void context"
 390     );
 391
 392     # test create() as we have everything set up already
 393     $rs->delete;
 394     $rs->create($_) for @{$args->{$tst}};
 395
 396     is_deeply(
 397       $rs->all_hri,
 398       $args->{$tst},
 399       "Create() $tst"
 400     );
 401   }
 402
 403   ok (
 404     ($preimage eq nfreeze( [$fn, $fn2, $rank, $args] )),
 405     'Arguments fed to populate()/create() unchanged'
 406   );
 407
 408   $rs->delete;
 409 } [
 410   # warning to be removed around Apr 1st 2015
 411   # smokers start failing a month before that
 412   (
 413     ( DBICTest::RunMode->is_author and ( time() > 1427846400 ) )
 414       or
 415     ( DBICTest::RunMode->is_smoker and ( time() > 1425168000 ) )
 416   )
 417     ? ()
 418     # one unique for populate() and create() each
 419     : (qr/\QPOSSIBLE *PAST* DATA CORRUPTION detected \E.+\QTrigger condition encountered at @{[ __FILE__ ]} line\E \d/) x 3
 420 ], 'Data integrity warnings as planned';
 421
 422 lives_ok {
 423    $schema->resultset('TwoKeys')->populate([{
 424       artist => 1,
 425       cd     => 5,
 426       fourkeys_to_twokeys => [{
 427             f_foo => 1,
 428             f_bar => 1,
 429             f_hello => 1,
 430             f_goodbye => 1,
 431             autopilot => 'a',
 432       },{
 433             f_foo => 2,
 434             f_bar => 2,
 435             f_hello => 2,
 436             f_goodbye => 2,
 437             autopilot => 'b',
 438       }]
 439    }])
 440 } 'multicol-PK has_many populate works';
 441
 442 lives_ok ( sub {
 443   $schema->populate('CD', [
 444     {cdid => 10001, artist => $artist->id, title => 'Pretty Much Empty', year => 2011, tracks => []},
 445   ])
 446 }, 'empty has_many relationship accepted by populate');
 447
 448 done_testing;