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