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