(travis) Various TravisCI improvements lifted from blead
[dbsrgits/DBIx-Class.git] / 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 # or with empty sets
387 warnings_like {
388   my $rs = $schema->resultset('Artist')->search({}, { columns => [qw(name rank)], order_by => 'artistid' });
389
390   # the stringification has nothing to do with the artist name
391   # this is solely for testing consistency
392   my $fn = Path::Class::File->new ('somedir/somefilename.tmp');
393   my $fn2 = Path::Class::File->new ('somedir/someotherfilename.tmp');
394   my $rank = Math::BigInt->new(42);
395
396   my $args = {
397     'stringifying objects after regular values' => { AoA => [
398       [qw( name rank )],
399       ( map { [ $_, $rank ] } (
400         'supplied before stringifying objects',
401         'supplied before stringifying objects 2',
402         $fn,
403         $fn2,
404       )),
405     ]},
406
407     'stringifying objects before regular values' => { AoA => [
408       [qw( rank name )],
409       ( map { [ $rank, $_ ] } (
410         $fn,
411         $fn2,
412         'supplied after stringifying objects',
413         'supplied after stringifying objects 2',
414       )),
415     ]},
416
417     'stringifying objects between regular values' => { AoA => [
418       [qw( name rank )],
419       ( map { [ $_, $rank ] } (
420         'supplied before stringifying objects',
421         $fn,
422         $fn2,
423         'supplied after stringifying objects',
424       ))
425     ]},
426
427     'stringifying objects around regular values' => { AoA => [
428       [qw( rank name )],
429       ( map { [ $rank, $_ ] } (
430         $fn,
431         'supplied between stringifying objects',
432         $fn2,
433       ))
434     ]},
435
436     'single stringifying object' => { AoA => [
437       [qw( rank name )],
438       [ $rank, $fn ],
439     ]},
440
441     'empty set' => { AoA => [
442       [qw( name rank )],
443     ]},
444   };
445
446   # generate the AoH equivalent based on the AoAs above
447   for my $bag (values %$args) {
448     $bag->{AoH} = [];
449     my @hdr = @{$bag->{AoA}[0]};
450     for my $v ( @{$bag->{AoA}}[1..$#{$bag->{AoA}}] ) {
451       push @{$bag->{AoH}}, my $h = {};
452       @{$h}{@hdr} = @$v;
453     }
454   }
455
456   local $Storable::canonical = 1;
457   my $preimage = nfreeze($args);
458
459
460   for my $tst (keys %$args) {
461     for my $type (qw(AoA AoH)) {
462
463       # test void ctx
464       $rs->delete;
465       $rs->populate($args->{$tst}{$type});
466       is_deeply(
467         $rs->all_hri,
468         $args->{$tst}{AoH},
469         "Populate() $tst in void context"
470       );
471
472       # test scalar ctx
473       $rs->delete;
474       my $dummy = $rs->populate($args->{$tst}{$type});
475       is_deeply(
476         $rs->all_hri,
477         $args->{$tst}{AoH},
478         "Populate() $tst in non-void context"
479       );
480
481       # test list ctx
482       $rs->delete;
483       my @dummy = $rs->populate($args->{$tst}{$type});
484       is_deeply(
485         $rs->all_hri,
486         $args->{$tst}{AoH},
487         "Populate() $tst in non-void context"
488       );
489     }
490
491     # test create() as we have everything set up already
492     $rs->delete;
493     $rs->create($_) for @{$args->{$tst}{AoH}};
494
495     is_deeply(
496       $rs->all_hri,
497       $args->{$tst}{AoH},
498       "Create() $tst"
499     );
500   }
501
502   ok (
503     ($preimage eq nfreeze($args)),
504     'Arguments fed to populate()/create() unchanged'
505   );
506
507   $rs->delete;
508 } [], 'Data integrity warnings gone as planned';
509
510 $schema->is_executed_sql_bind(
511   sub {
512    $schema->resultset('TwoKeys')->populate([{
513       artist => 1,
514       cd     => 5,
515       fourkeys_to_twokeys => [{
516             f_foo => 1,
517             f_bar => 1,
518             f_hello => 1,
519             f_goodbye => 1,
520             autopilot => 'a',
521       },{
522             f_foo => 2,
523             f_bar => 2,
524             f_hello => 2,
525             f_goodbye => 2,
526             autopilot => 'b',
527       }]
528    }])
529   },
530   [
531     [ 'BEGIN' ],
532     [ 'INSERT INTO twokeys ( artist, cd)
533         VALUES ( ?, ? )',
534       '__BULK_INSERT__'
535     ],
536     [ 'INSERT INTO fourkeys_to_twokeys ( autopilot, f_bar, f_foo, f_goodbye, f_hello, t_artist, t_cd)
537         VALUES (
538           ?, ?, ?, ?, ?,
539           ( SELECT me.artist FROM twokeys me WHERE artist = ? AND cd = ? ),
540           ( SELECT me.cd FROM twokeys me WHERE artist = ? AND cd = ? )
541         )
542       ',
543       '__BULK_INSERT__'
544     ],
545     [ 'COMMIT' ],
546   ],
547   'multicol-PK has_many populate expected trace'
548 );
549
550 lives_ok ( sub {
551   $schema->populate('CD', [
552     {cdid => 10001, artist => $artist->id, title => 'Pretty Much Empty', year => 2011, tracks => []},
553   ])
554 }, 'empty has_many relationship accepted by populate');
555
556 done_testing;