Commit | Line | Data |
54e0bd06 |
1 | use strict; |
d35a6fed |
2 | use warnings; |
54e0bd06 |
3 | |
4 | use Test::More; |
d35a6fed |
5 | use Test::Exception; |
75a1d824 |
6 | use Test::Warn; |
54e0bd06 |
7 | use lib qw(t/lib); |
8 | use DBICTest; |
1c30a2e4 |
9 | use DBIx::Class::_Util qw(sigwarn_silencer serialize); |
75a1d824 |
10 | use Math::BigInt; |
569b9fe6 |
11 | use List::Util qw/shuffle/; |
54e0bd06 |
12 | |
f6d731aa |
13 | { |
14 | package DBICTest::StringifiesOnly; |
15 | use overload |
16 | '""' => sub { $_[0]->[0] }, |
17 | fallback => 0, |
18 | ; |
19 | } |
20 | { |
21 | package DBICTest::StringifiesViaFallback; |
22 | use overload |
23 | 'bool' => sub { $_[0]->[0] }, |
24 | ; |
25 | } |
26 | |
54e0bd06 |
27 | my $schema = DBICTest->init_schema(); |
54e0bd06 |
28 | |
d35a6fed |
29 | # The map below generates stuff like: |
30 | # [ qw/artistid name/ ], |
31 | # [ 4, "b" ], |
32 | # [ 5, "c" ], |
33 | # ... |
34 | # [ 9999, "ntm" ], |
35 | # [ 10000, "ntn" ], |
36 | |
37 | my $start_id = 'populateXaaaaaa'; |
569b9fe6 |
38 | my $rows = 10_000; |
d35a6fed |
39 | my $offset = 3; |
40 | |
569b9fe6 |
41 | $schema->populate('Artist', [ [ qw/artistid name/ ], map { [ ($_ + $offset) => $start_id++ ] } shuffle ( 1 .. $rows ) ] ); |
d35a6fed |
42 | is ( |
43 | $schema->resultset ('Artist')->search ({ name => { -like => 'populateX%' } })->count, |
44 | $rows, |
45 | 'populate created correct number of rows with massive AoA bulk insert', |
46 | ); |
47 | |
48 | my $artist = $schema->resultset ('Artist') |
49 | ->search ({ 'cds.title' => { '!=', undef } }, { join => 'cds' }) |
50 | ->first; |
51 | my $ex_title = $artist->cds->first->title; |
52 | |
53 | throws_ok ( sub { |
54 | my $i = 600; |
55 | $schema->populate('CD', [ |
56 | map { |
57 | { |
d35a6fed |
58 | artist => $artist->id, |
59 | title => $_, |
60 | year => 2009, |
61 | } |
62 | } ('Huey', 'Dewey', $ex_title, 'Louie') |
63 | ]) |
52cef7e3 |
64 | }, qr/\Qexecute_for_fetch() aborted with '\E.+ at populate slice.+$ex_title/ms, 'Readable exception thrown for failed populate'); |
b0457415 |
65 | |
89b2e3e4 |
66 | ## make sure populate honors fields/orders in list context |
b0457415 |
67 | ## schema order |
89b2e3e4 |
68 | my @links = $schema->populate('Link', [ |
b0457415 |
69 | [ qw/id url title/ ], |
70 | [ qw/2 burl btitle/ ] |
71 | ]); |
89b2e3e4 |
72 | is(scalar @links, 1); |
73 | |
74 | my $link2 = shift @links; |
b0457415 |
75 | is($link2->id, 2, 'Link 2 id'); |
76 | is($link2->url, 'burl', 'Link 2 url'); |
77 | is($link2->title, 'btitle', 'Link 2 title'); |
78 | |
79 | ## non-schema order |
89b2e3e4 |
80 | @links = $schema->populate('Link', [ |
b0457415 |
81 | [ qw/id title url/ ], |
82 | [ qw/3 ctitle curl/ ] |
83 | ]); |
89b2e3e4 |
84 | is(scalar @links, 1); |
85 | |
86 | my $link3 = shift @links; |
b0457415 |
87 | is($link3->id, 3, 'Link 3 id'); |
88 | is($link3->url, 'curl', 'Link 3 url'); |
89 | is($link3->title, 'ctitle', 'Link 3 title'); |
90 | |
91 | ## not all physical columns |
89b2e3e4 |
92 | @links = $schema->populate('Link', [ |
b0457415 |
93 | [ qw/id title/ ], |
94 | [ qw/4 dtitle/ ] |
95 | ]); |
89b2e3e4 |
96 | is(scalar @links, 1); |
97 | |
98 | my $link4 = shift @links; |
b0457415 |
99 | is($link4->id, 4, 'Link 4 id'); |
100 | is($link4->url, undef, 'Link 4 url'); |
101 | is($link4->title, 'dtitle', 'Link 4 title'); |
102 | |
d0cefd99 |
103 | ## variable size dataset |
104 | @links = $schema->populate('Link', [ |
105 | [ qw/id title url/ ], |
106 | [ 41 ], |
107 | [ 42, undef, 'url42' ], |
108 | ]); |
109 | is(scalar @links, 2); |
110 | is($links[0]->url, undef); |
111 | is($links[1]->url, 'url42'); |
b0457415 |
112 | |
2a6dda4b |
113 | ## make sure populate -> _insert_bulk honors fields/orders in void context |
89b2e3e4 |
114 | ## schema order |
115 | $schema->populate('Link', [ |
116 | [ qw/id url title/ ], |
117 | [ qw/5 eurl etitle/ ] |
118 | ]); |
119 | my $link5 = $schema->resultset('Link')->find(5); |
120 | is($link5->id, 5, 'Link 5 id'); |
121 | is($link5->url, 'eurl', 'Link 5 url'); |
122 | is($link5->title, 'etitle', 'Link 5 title'); |
123 | |
124 | ## non-schema order |
125 | $schema->populate('Link', [ |
126 | [ qw/id title url/ ], |
127 | [ qw/6 ftitle furl/ ] |
128 | ]); |
129 | my $link6 = $schema->resultset('Link')->find(6); |
130 | is($link6->id, 6, 'Link 6 id'); |
131 | is($link6->url, 'furl', 'Link 6 url'); |
132 | is($link6->title, 'ftitle', 'Link 6 title'); |
133 | |
134 | ## not all physical columns |
135 | $schema->populate('Link', [ |
136 | [ qw/id title/ ], |
137 | [ qw/7 gtitle/ ] |
138 | ]); |
139 | my $link7 = $schema->resultset('Link')->find(7); |
140 | is($link7->id, 7, 'Link 7 id'); |
141 | is($link7->url, undef, 'Link 7 url'); |
142 | is($link7->title, 'gtitle', 'Link 7 title'); |
143 | |
d0cefd99 |
144 | ## variable size dataset in void ctx |
145 | $schema->populate('Link', [ |
146 | [ qw/id title url/ ], |
147 | [ 71 ], |
148 | [ 72, undef, 'url72' ], |
149 | ]); |
150 | @links = $schema->resultset('Link')->search({ id => [71, 72]}, { order_by => 'id' })->all; |
151 | is(scalar @links, 2); |
152 | is($links[0]->url, undef); |
153 | is($links[1]->url, 'url72'); |
154 | |
155 | ## variable size dataset in void ctx, hash version |
156 | $schema->populate('Link', [ |
157 | { id => 73 }, |
158 | { id => 74, title => 't74' }, |
159 | { id => 75, url => 'u75' }, |
160 | ]); |
161 | @links = $schema->resultset('Link')->search({ id => [73..75]}, { order_by => 'id' })->all; |
162 | is(scalar @links, 3); |
163 | is($links[0]->url, undef); |
164 | is($links[0]->title, undef); |
165 | is($links[1]->url, undef); |
166 | is($links[1]->title, 't74'); |
167 | is($links[2]->url, 'u75'); |
168 | is($links[2]->title, undef); |
169 | |
170 | ## Make sure the void ctx trace is sane |
171 | { |
172 | for ( |
173 | [ |
174 | [ qw/id title url/ ], |
175 | [ 81 ], |
176 | [ 82, 't82' ], |
177 | [ 83, undef, 'url83' ], |
178 | ], |
179 | [ |
180 | { id => 91 }, |
181 | { id => 92, title => 't92' }, |
182 | { id => 93, url => 'url93' }, |
183 | ] |
184 | ) { |
185 | $schema->is_executed_sql_bind( |
186 | sub { |
187 | $schema->populate('Link', $_); |
188 | }, |
189 | [ |
190 | [ 'BEGIN' ], |
191 | [ |
192 | 'INSERT INTO link( id, title, url ) VALUES( ?, ?, ? )', |
193 | "__BULK_INSERT__" |
194 | ], |
195 | [ 'COMMIT' ], |
196 | ] |
197 | ); |
198 | } |
199 | } |
200 | |
84f7e8a1 |
201 | # populate with literals |
202 | { |
203 | my $rs = $schema->resultset('Link'); |
204 | $rs->delete; |
aac0bfd0 |
205 | |
2a6dda4b |
206 | # test populate with all literal sql (no binds) |
aac0bfd0 |
207 | |
84f7e8a1 |
208 | $rs->populate([ |
574d7df6 |
209 | (+{ |
84f7e8a1 |
210 | url => \"'cpan.org'", |
211 | title => \"'The ''best of'' cpan'", |
574d7df6 |
212 | }) x 5 |
84f7e8a1 |
213 | ]); |
574d7df6 |
214 | |
84f7e8a1 |
215 | is((grep { |
216 | $_->url eq 'cpan.org' && |
217 | $_->title eq "The 'best of' cpan", |
218 | } $rs->all), 5, 'populate with all literal SQL'); |
bbd6f348 |
219 | |
84f7e8a1 |
220 | $rs->delete; |
bbd6f348 |
221 | |
84f7e8a1 |
222 | # test mixed binds with literal sql |
aac0bfd0 |
223 | |
84f7e8a1 |
224 | $rs->populate([ |
aac0bfd0 |
225 | (+{ |
84f7e8a1 |
226 | url => \"'cpan.org'", |
227 | title => "The 'best of' cpan", |
aac0bfd0 |
228 | }) x 5 |
84f7e8a1 |
229 | ]); |
aac0bfd0 |
230 | |
84f7e8a1 |
231 | is((grep { |
232 | $_->url eq 'cpan.org' && |
233 | $_->title eq "The 'best of' cpan", |
234 | } $rs->all), 5, 'populate with all literal SQL'); |
aac0bfd0 |
235 | |
84f7e8a1 |
236 | $rs->delete; |
237 | } |
aac0bfd0 |
238 | |
a9bac98f |
239 | # populate with literal+bind |
240 | { |
241 | my $rs = $schema->resultset('Link'); |
242 | $rs->delete; |
243 | |
2a6dda4b |
244 | # test populate with all literal/bind sql |
a9bac98f |
245 | $rs->populate([ |
246 | (+{ |
247 | url => \['?', [ {} => 'cpan.org' ] ], |
248 | title => \['?', [ {} => "The 'best of' cpan" ] ], |
249 | }) x 5 |
250 | ]); |
251 | |
252 | is((grep { |
253 | $_->url eq 'cpan.org' && |
254 | $_->title eq "The 'best of' cpan", |
255 | } $rs->all), 5, 'populate with all literal/bind'); |
256 | |
257 | $rs->delete; |
258 | |
2a6dda4b |
259 | # test populate with mix literal and literal/bind |
a9bac98f |
260 | $rs->populate([ |
261 | (+{ |
262 | url => \"'cpan.org'", |
263 | title => \['?', [ {} => "The 'best of' cpan" ] ], |
264 | }) x 5 |
265 | ]); |
266 | |
267 | is((grep { |
268 | $_->url eq 'cpan.org' && |
269 | $_->title eq "The 'best of' cpan", |
270 | } $rs->all), 5, 'populate with all literal/bind SQL'); |
271 | |
272 | $rs->delete; |
273 | |
274 | # test mixed binds with literal sql/bind |
275 | |
276 | $rs->populate([ map { +{ |
90b2bd88 |
277 | url => \[ '? || ?', [ {} => 'cpan.org_' ], $_ ], |
a9bac98f |
278 | title => "The 'best of' cpan", |
279 | } } (1 .. 5) ]); |
280 | |
281 | for (1 .. 5) { |
282 | ok($rs->find({ url => "cpan.org_$_" }), "Row $_ correctly created with dynamic literal/bind populate" ); |
283 | } |
284 | |
285 | $rs->delete; |
286 | } |
287 | |
84f7e8a1 |
288 | my $rs = $schema->resultset('Artist'); |
289 | $rs->delete; |
bbd6f348 |
290 | throws_ok { |
a4c52abc |
291 | # this warning is correct, but we are not testing it here |
292 | # what we are after is the correct exception when an int |
293 | # fails to coerce into a sqlite rownum |
294 | local $SIG{__WARN__} = sigwarn_silencer( qr/datatype mismatch.+ foo as integer/ ); |
295 | |
bbd6f348 |
296 | $rs->populate([ |
297 | { |
298 | artistid => 1, |
299 | name => 'foo1', |
300 | }, |
301 | { |
302 | artistid => 'foo', # this dies |
303 | name => 'foo2', |
304 | }, |
305 | { |
306 | artistid => 3, |
307 | name => 'foo3', |
308 | }, |
309 | ]); |
a4c52abc |
310 | } qr/\Qexecute_for_fetch() aborted with 'datatype mismatch\E\b/, 'bad slice fails PK insert'; |
bbd6f348 |
311 | |
312 | is($rs->count, 0, 'populate is atomic'); |
313 | |
1295943f |
314 | # Trying to use a column marked as a bind in the first slice with literal sql in |
315 | # a later slice should throw. |
316 | |
317 | throws_ok { |
318 | $rs->populate([ |
319 | { |
320 | artistid => 1, |
321 | name => \"'foo'", |
322 | }, |
323 | { |
324 | artistid => \2, |
325 | name => \"'foo'", |
326 | } |
327 | ]); |
f6faeab8 |
328 | } qr/Literal SQL found where a plain bind value is expected/, 'literal sql where bind expected throws'; |
1295943f |
329 | |
330 | # ... and vice-versa. |
331 | |
332 | throws_ok { |
333 | $rs->populate([ |
334 | { |
335 | artistid => \1, |
336 | name => \"'foo'", |
337 | }, |
338 | { |
339 | artistid => 2, |
340 | name => \"'foo'", |
341 | } |
342 | ]); |
f6faeab8 |
343 | } qr/\QIncorrect value (expecting SCALAR-ref/, 'bind where literal sql expected throws'; |
1295943f |
344 | |
345 | throws_ok { |
346 | $rs->populate([ |
347 | { |
348 | artistid => 1, |
349 | name => \"'foo'", |
350 | }, |
351 | { |
352 | artistid => 2, |
353 | name => \"'bar'", |
354 | } |
355 | ]); |
f6faeab8 |
356 | } qr/Inconsistent literal SQL value/, 'literal sql must be the same in all slices'; |
1295943f |
357 | |
a9bac98f |
358 | throws_ok { |
359 | $rs->populate([ |
360 | { |
361 | artistid => 1, |
362 | name => \['?', [ {} => 'foo' ] ], |
363 | }, |
364 | { |
365 | artistid => 2, |
366 | name => \"'bar'", |
367 | } |
368 | ]); |
369 | } qr/\QIncorrect value (expecting ARRAYREF-ref/, 'literal where literal+bind expected throws'; |
370 | |
371 | throws_ok { |
372 | $rs->populate([ |
373 | { |
374 | artistid => 1, |
375 | name => \['?', [ { sqlt_datatype => 'foooo' } => 'foo' ] ], |
376 | }, |
377 | { |
378 | artistid => 2, |
379 | name => \['?', [ {} => 'foo' ] ], |
380 | } |
381 | ]); |
382 | } qr/\QDiffering bind attributes on literal\/bind values not supported for column 'name'/, 'literal+bind with differing attrs throws'; |
383 | |
384 | lives_ok { |
385 | $rs->populate([ |
386 | { |
387 | artistid => 1, |
388 | name => \['?', [ undef, 'foo' ] ], |
389 | }, |
390 | { |
391 | artistid => 2, |
392 | name => \['?', [ {} => 'bar' ] ], |
393 | } |
394 | ]); |
395 | } 'literal+bind with semantically identical attrs works after normalization'; |
396 | |
75a1d824 |
397 | # test all kinds of population with stringified objects |
277e3014 |
398 | # or with empty sets |
75a1d824 |
399 | warnings_like { |
400 | my $rs = $schema->resultset('Artist')->search({}, { columns => [qw(name rank)], order_by => 'artistid' }); |
401 | |
402 | # the stringification has nothing to do with the artist name |
403 | # this is solely for testing consistency |
f6d731aa |
404 | my $fn = bless [ 'somedir/somefilename.tmp' ], 'DBICTest::StringifiesOnly'; |
405 | my $fn2 = bless [ 'somedir/someotherfilename.tmp' ], 'DBICTest::StringifiesViaFallback'; |
75a1d824 |
406 | my $rank = Math::BigInt->new(42); |
407 | |
408 | my $args = { |
0a768c90 |
409 | 'stringifying objects after regular values' => { AoA => [ |
410 | [qw( name rank )], |
411 | ( map { [ $_, $rank ] } ( |
75a1d824 |
412 | 'supplied before stringifying objects', |
413 | 'supplied before stringifying objects 2', |
414 | $fn, |
415 | $fn2, |
0a768c90 |
416 | )), |
417 | ]}, |
418 | |
419 | 'stringifying objects before regular values' => { AoA => [ |
420 | [qw( rank name )], |
421 | ( map { [ $rank, $_ ] } ( |
75a1d824 |
422 | $fn, |
423 | $fn2, |
424 | 'supplied after stringifying objects', |
425 | 'supplied after stringifying objects 2', |
0a768c90 |
426 | )), |
427 | ]}, |
428 | |
429 | 'stringifying objects between regular values' => { AoA => [ |
430 | [qw( name rank )], |
431 | ( map { [ $_, $rank ] } ( |
75a1d824 |
432 | 'supplied before stringifying objects', |
433 | $fn, |
434 | $fn2, |
435 | 'supplied after stringifying objects', |
0a768c90 |
436 | )) |
437 | ]}, |
438 | |
439 | 'stringifying objects around regular values' => { AoA => [ |
440 | [qw( rank name )], |
441 | ( map { [ $rank, $_ ] } ( |
75a1d824 |
442 | $fn, |
443 | 'supplied between stringifying objects', |
444 | $fn2, |
0a768c90 |
445 | )) |
446 | ]}, |
447 | |
448 | 'single stringifying object' => { AoA => [ |
449 | [qw( rank name )], |
450 | [ $rank, $fn ], |
451 | ]}, |
277e3014 |
452 | |
453 | 'empty set' => { AoA => [ |
454 | [qw( name rank )], |
455 | ]}, |
75a1d824 |
456 | }; |
457 | |
0a768c90 |
458 | # generate the AoH equivalent based on the AoAs above |
f6d731aa |
459 | # also generate the expected HRI output ( is_deeply is too smart for its own good ) |
0a768c90 |
460 | for my $bag (values %$args) { |
277e3014 |
461 | $bag->{AoH} = []; |
f6d731aa |
462 | $bag->{Expected} = []; |
0a768c90 |
463 | my @hdr = @{$bag->{AoA}[0]}; |
464 | for my $v ( @{$bag->{AoA}}[1..$#{$bag->{AoA}}] ) { |
465 | push @{$bag->{AoH}}, my $h = {}; |
466 | @{$h}{@hdr} = @$v; |
f6d731aa |
467 | |
468 | push @{$bag->{Expected}}, my $hs = {}; |
469 | @{$hs}{@hdr} = map { "$_" } @$v; |
0a768c90 |
470 | } |
471 | } |
75a1d824 |
472 | |
0a768c90 |
473 | local $Storable::canonical = 1; |
1c30a2e4 |
474 | my $preimage = serialize($args); |
75a1d824 |
475 | |
75a1d824 |
476 | |
0a768c90 |
477 | for my $tst (keys %$args) { |
478 | for my $type (qw(AoA AoH)) { |
479 | |
480 | # test void ctx |
481 | $rs->delete; |
482 | $rs->populate($args->{$tst}{$type}); |
483 | is_deeply( |
484 | $rs->all_hri, |
f6d731aa |
485 | $args->{$tst}{Expected}, |
0a768c90 |
486 | "Populate() $tst in void context" |
487 | ); |
488 | |
489 | # test scalar ctx |
490 | $rs->delete; |
491 | my $dummy = $rs->populate($args->{$tst}{$type}); |
492 | is_deeply( |
493 | $rs->all_hri, |
f6d731aa |
494 | $args->{$tst}{Expected}, |
0a768c90 |
495 | "Populate() $tst in non-void context" |
496 | ); |
497 | |
498 | # test list ctx |
499 | $rs->delete; |
500 | my @dummy = $rs->populate($args->{$tst}{$type}); |
501 | is_deeply( |
502 | $rs->all_hri, |
f6d731aa |
503 | $args->{$tst}{Expected}, |
0a768c90 |
504 | "Populate() $tst in non-void context" |
505 | ); |
506 | } |
75a1d824 |
507 | |
508 | # test create() as we have everything set up already |
509 | $rs->delete; |
0a768c90 |
510 | $rs->create($_) for @{$args->{$tst}{AoH}}; |
75a1d824 |
511 | |
512 | is_deeply( |
513 | $rs->all_hri, |
f6d731aa |
514 | $args->{$tst}{Expected}, |
75a1d824 |
515 | "Create() $tst" |
516 | ); |
517 | } |
8464d1a4 |
518 | |
75a1d824 |
519 | ok ( |
1c30a2e4 |
520 | ($preimage eq serialize($args)), |
75a1d824 |
521 | 'Arguments fed to populate()/create() unchanged' |
522 | ); |
8464d1a4 |
523 | |
75a1d824 |
524 | $rs->delete; |
cff17b97 |
525 | } [], 'Data integrity warnings gone as planned'; |
8464d1a4 |
526 | |
d0cefd99 |
527 | $schema->is_executed_sql_bind( |
528 | sub { |
18d80024 |
529 | $schema->resultset('TwoKeys')->populate([{ |
530 | artist => 1, |
531 | cd => 5, |
532 | fourkeys_to_twokeys => [{ |
533 | f_foo => 1, |
534 | f_bar => 1, |
535 | f_hello => 1, |
536 | f_goodbye => 1, |
537 | autopilot => 'a', |
538 | },{ |
539 | f_foo => 2, |
540 | f_bar => 2, |
541 | f_hello => 2, |
542 | f_goodbye => 2, |
543 | autopilot => 'b', |
544 | }] |
545 | }]) |
d0cefd99 |
546 | }, |
547 | [ |
548 | [ 'BEGIN' ], |
549 | [ 'INSERT INTO twokeys ( artist, cd) |
550 | VALUES ( ?, ? )', |
551 | '__BULK_INSERT__' |
552 | ], |
553 | [ 'INSERT INTO fourkeys_to_twokeys ( autopilot, f_bar, f_foo, f_goodbye, f_hello, t_artist, t_cd) |
554 | VALUES ( |
555 | ?, ?, ?, ?, ?, |
556 | ( SELECT me.artist FROM twokeys me WHERE artist = ? AND cd = ? ), |
557 | ( SELECT me.cd FROM twokeys me WHERE artist = ? AND cd = ? ) |
558 | ) |
559 | ', |
560 | '__BULK_INSERT__' |
561 | ], |
562 | [ 'COMMIT' ], |
563 | ], |
564 | 'multicol-PK has_many populate expected trace' |
565 | ); |
18d80024 |
566 | |
d6170b26 |
567 | lives_ok ( sub { |
568 | $schema->populate('CD', [ |
569 | {cdid => 10001, artist => $artist->id, title => 'Pretty Much Empty', year => 2011, tracks => []}, |
570 | ]) |
571 | }, 'empty has_many relationship accepted by populate'); |
572 | |
bbd6f348 |
573 | done_testing; |