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; |
a4c52abc |
9 | use DBIx::Class::_Util 'sigwarn_silencer'; |
c0d8cb1f |
10 | use Path::Class::File (); |
75a1d824 |
11 | use Math::BigInt; |
569b9fe6 |
12 | use List::Util qw/shuffle/; |
75a1d824 |
13 | use Storable qw/nfreeze dclone/; |
54e0bd06 |
14 | |
54e0bd06 |
15 | my $schema = DBICTest->init_schema(); |
54e0bd06 |
16 | |
d35a6fed |
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'; |
d58f0098 |
26 | my $rows = 10; |
d35a6fed |
27 | my $offset = 3; |
28 | |
569b9fe6 |
29 | $schema->populate('Artist', [ [ qw/artistid name/ ], map { [ ($_ + $offset) => $start_id++ ] } shuffle ( 1 .. $rows ) ] ); |
d35a6fed |
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 | { |
d35a6fed |
46 | artist => $artist->id, |
47 | title => $_, |
48 | year => 2009, |
49 | } |
50 | } ('Huey', 'Dewey', $ex_title, 'Louie') |
51 | ]) |
52cef7e3 |
52 | }, qr/\Qexecute_for_fetch() aborted with '\E.+ at populate slice.+$ex_title/ms, 'Readable exception thrown for failed populate'); |
b0457415 |
53 | |
89b2e3e4 |
54 | ## make sure populate honors fields/orders in list context |
b0457415 |
55 | ## schema order |
89b2e3e4 |
56 | my @links = $schema->populate('Link', [ |
b0457415 |
57 | [ qw/id url title/ ], |
58 | [ qw/2 burl btitle/ ] |
59 | ]); |
89b2e3e4 |
60 | is(scalar @links, 1); |
61 | |
62 | my $link2 = shift @links; |
b0457415 |
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 |
89b2e3e4 |
68 | @links = $schema->populate('Link', [ |
b0457415 |
69 | [ qw/id title url/ ], |
70 | [ qw/3 ctitle curl/ ] |
71 | ]); |
89b2e3e4 |
72 | is(scalar @links, 1); |
73 | |
74 | my $link3 = shift @links; |
b0457415 |
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 |
89b2e3e4 |
80 | @links = $schema->populate('Link', [ |
b0457415 |
81 | [ qw/id title/ ], |
82 | [ qw/4 dtitle/ ] |
83 | ]); |
89b2e3e4 |
84 | is(scalar @links, 1); |
85 | |
86 | my $link4 = shift @links; |
b0457415 |
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 | |
89b2e3e4 |
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 | |
84f7e8a1 |
123 | # populate with literals |
124 | { |
125 | my $rs = $schema->resultset('Link'); |
126 | $rs->delete; |
aac0bfd0 |
127 | |
52cef7e3 |
128 | # test insert_bulk with all literal sql (no binds) |
aac0bfd0 |
129 | |
84f7e8a1 |
130 | $rs->populate([ |
574d7df6 |
131 | (+{ |
84f7e8a1 |
132 | url => \"'cpan.org'", |
133 | title => \"'The ''best of'' cpan'", |
574d7df6 |
134 | }) x 5 |
84f7e8a1 |
135 | ]); |
574d7df6 |
136 | |
84f7e8a1 |
137 | is((grep { |
138 | $_->url eq 'cpan.org' && |
139 | $_->title eq "The 'best of' cpan", |
140 | } $rs->all), 5, 'populate with all literal SQL'); |
bbd6f348 |
141 | |
84f7e8a1 |
142 | $rs->delete; |
bbd6f348 |
143 | |
84f7e8a1 |
144 | # test mixed binds with literal sql |
aac0bfd0 |
145 | |
84f7e8a1 |
146 | $rs->populate([ |
aac0bfd0 |
147 | (+{ |
84f7e8a1 |
148 | url => \"'cpan.org'", |
149 | title => "The 'best of' cpan", |
aac0bfd0 |
150 | }) x 5 |
84f7e8a1 |
151 | ]); |
aac0bfd0 |
152 | |
84f7e8a1 |
153 | is((grep { |
154 | $_->url eq 'cpan.org' && |
155 | $_->title eq "The 'best of' cpan", |
156 | } $rs->all), 5, 'populate with all literal SQL'); |
aac0bfd0 |
157 | |
84f7e8a1 |
158 | $rs->delete; |
159 | } |
aac0bfd0 |
160 | |
a9bac98f |
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_' ], [ undef, $_ ] ], |
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 | |
84f7e8a1 |
210 | my $rs = $schema->resultset('Artist'); |
211 | $rs->delete; |
bbd6f348 |
212 | throws_ok { |
a4c52abc |
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 | |
bbd6f348 |
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 | ]); |
a4c52abc |
232 | } qr/\Qexecute_for_fetch() aborted with 'datatype mismatch\E\b/, 'bad slice fails PK insert'; |
bbd6f348 |
233 | |
234 | is($rs->count, 0, 'populate is atomic'); |
235 | |
1295943f |
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 | ]); |
f6faeab8 |
250 | } qr/Literal SQL found where a plain bind value is expected/, 'literal sql where bind expected throws'; |
1295943f |
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 | ]); |
f6faeab8 |
265 | } qr/\QIncorrect value (expecting SCALAR-ref/, 'bind where literal sql expected throws'; |
1295943f |
266 | |
267 | throws_ok { |
268 | $rs->populate([ |
269 | { |
270 | artistid => 1, |
271 | name => \"'foo'", |
272 | }, |
273 | { |
274 | artistid => 2, |
275 | name => \"'bar'", |
276 | } |
277 | ]); |
f6faeab8 |
278 | } qr/Inconsistent literal SQL value/, 'literal sql must be the same in all slices'; |
1295943f |
279 | |
a9bac98f |
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 | |
75a1d824 |
319 | # test all kinds of population with stringified objects |
320 | warnings_like { |
eed5492f |
321 | local $ENV{DBIC_RT79576_NOWARN}; |
322 | |
75a1d824 |
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 | } |
8464d1a4 |
402 | |
75a1d824 |
403 | ok ( |
404 | ($preimage eq nfreeze( [$fn, $fn2, $rank, $args] )), |
405 | 'Arguments fed to populate()/create() unchanged' |
406 | ); |
8464d1a4 |
407 | |
75a1d824 |
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 2 |
420 | ], 'Data integrity warnings as planned'; |
8464d1a4 |
421 | |
18d80024 |
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 | }]) |
d6eda469 |
440 | } 'multicol-PK has_many populate works'; |
18d80024 |
441 | |
d6170b26 |
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 | |
bbd6f348 |
448 | done_testing; |