Add a self-explanatory *compile-time* $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS}
[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
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;