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