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; |
c0d8cb1f |
9 | use Path::Class::File (); |
75a1d824 |
10 | use Math::BigInt; |
569b9fe6 |
11 | use List::Util qw/shuffle/; |
75a1d824 |
12 | use Storable qw/nfreeze dclone/; |
54e0bd06 |
13 | |
54e0bd06 |
14 | my $schema = DBICTest->init_schema(); |
54e0bd06 |
15 | |
d35a6fed |
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'; |
569b9fe6 |
25 | my $rows = 10_000; |
d35a6fed |
26 | my $offset = 3; |
27 | |
569b9fe6 |
28 | $schema->populate('Artist', [ [ qw/artistid name/ ], map { [ ($_ + $offset) => $start_id++ ] } shuffle ( 1 .. $rows ) ] ); |
d35a6fed |
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 | { |
d35a6fed |
45 | artist => $artist->id, |
46 | title => $_, |
47 | year => 2009, |
48 | } |
49 | } ('Huey', 'Dewey', $ex_title, 'Louie') |
50 | ]) |
52cef7e3 |
51 | }, qr/\Qexecute_for_fetch() aborted with '\E.+ at populate slice.+$ex_title/ms, 'Readable exception thrown for failed populate'); |
b0457415 |
52 | |
89b2e3e4 |
53 | ## make sure populate honors fields/orders in list context |
b0457415 |
54 | ## schema order |
89b2e3e4 |
55 | my @links = $schema->populate('Link', [ |
b0457415 |
56 | [ qw/id url title/ ], |
57 | [ qw/2 burl btitle/ ] |
58 | ]); |
89b2e3e4 |
59 | is(scalar @links, 1); |
60 | |
61 | my $link2 = shift @links; |
b0457415 |
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 |
89b2e3e4 |
67 | @links = $schema->populate('Link', [ |
b0457415 |
68 | [ qw/id title url/ ], |
69 | [ qw/3 ctitle curl/ ] |
70 | ]); |
89b2e3e4 |
71 | is(scalar @links, 1); |
72 | |
73 | my $link3 = shift @links; |
b0457415 |
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 |
89b2e3e4 |
79 | @links = $schema->populate('Link', [ |
b0457415 |
80 | [ qw/id title/ ], |
81 | [ qw/4 dtitle/ ] |
82 | ]); |
89b2e3e4 |
83 | is(scalar @links, 1); |
84 | |
85 | my $link4 = shift @links; |
b0457415 |
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 | |
89b2e3e4 |
91 | ## make sure populate -> insert_bulk honors fields/orders in void context |
92 | ## schema order |
93 | $schema->populate('Link', [ |
94 | [ qw/id url title/ ], |
95 | [ qw/5 eurl etitle/ ] |
96 | ]); |
97 | my $link5 = $schema->resultset('Link')->find(5); |
98 | is($link5->id, 5, 'Link 5 id'); |
99 | is($link5->url, 'eurl', 'Link 5 url'); |
100 | is($link5->title, 'etitle', 'Link 5 title'); |
101 | |
102 | ## non-schema order |
103 | $schema->populate('Link', [ |
104 | [ qw/id title url/ ], |
105 | [ qw/6 ftitle furl/ ] |
106 | ]); |
107 | my $link6 = $schema->resultset('Link')->find(6); |
108 | is($link6->id, 6, 'Link 6 id'); |
109 | is($link6->url, 'furl', 'Link 6 url'); |
110 | is($link6->title, 'ftitle', 'Link 6 title'); |
111 | |
112 | ## not all physical columns |
113 | $schema->populate('Link', [ |
114 | [ qw/id title/ ], |
115 | [ qw/7 gtitle/ ] |
116 | ]); |
117 | my $link7 = $schema->resultset('Link')->find(7); |
118 | is($link7->id, 7, 'Link 7 id'); |
119 | is($link7->url, undef, 'Link 7 url'); |
120 | is($link7->title, 'gtitle', 'Link 7 title'); |
121 | |
84f7e8a1 |
122 | # populate with literals |
123 | { |
124 | my $rs = $schema->resultset('Link'); |
125 | $rs->delete; |
aac0bfd0 |
126 | |
52cef7e3 |
127 | # test insert_bulk with all literal sql (no binds) |
aac0bfd0 |
128 | |
84f7e8a1 |
129 | $rs->populate([ |
574d7df6 |
130 | (+{ |
84f7e8a1 |
131 | url => \"'cpan.org'", |
132 | title => \"'The ''best of'' cpan'", |
574d7df6 |
133 | }) x 5 |
84f7e8a1 |
134 | ]); |
574d7df6 |
135 | |
84f7e8a1 |
136 | is((grep { |
137 | $_->url eq 'cpan.org' && |
138 | $_->title eq "The 'best of' cpan", |
139 | } $rs->all), 5, 'populate with all literal SQL'); |
bbd6f348 |
140 | |
84f7e8a1 |
141 | $rs->delete; |
bbd6f348 |
142 | |
84f7e8a1 |
143 | # test mixed binds with literal sql |
aac0bfd0 |
144 | |
84f7e8a1 |
145 | $rs->populate([ |
aac0bfd0 |
146 | (+{ |
84f7e8a1 |
147 | url => \"'cpan.org'", |
148 | title => "The 'best of' cpan", |
aac0bfd0 |
149 | }) x 5 |
84f7e8a1 |
150 | ]); |
aac0bfd0 |
151 | |
84f7e8a1 |
152 | is((grep { |
153 | $_->url eq 'cpan.org' && |
154 | $_->title eq "The 'best of' cpan", |
155 | } $rs->all), 5, 'populate with all literal SQL'); |
aac0bfd0 |
156 | |
84f7e8a1 |
157 | $rs->delete; |
158 | } |
aac0bfd0 |
159 | |
a9bac98f |
160 | # populate with literal+bind |
161 | { |
162 | my $rs = $schema->resultset('Link'); |
163 | $rs->delete; |
164 | |
165 | # test insert_bulk with all literal/bind sql |
166 | $rs->populate([ |
167 | (+{ |
168 | url => \['?', [ {} => 'cpan.org' ] ], |
169 | title => \['?', [ {} => "The 'best of' cpan" ] ], |
170 | }) x 5 |
171 | ]); |
172 | |
173 | is((grep { |
174 | $_->url eq 'cpan.org' && |
175 | $_->title eq "The 'best of' cpan", |
176 | } $rs->all), 5, 'populate with all literal/bind'); |
177 | |
178 | $rs->delete; |
179 | |
180 | # test insert_bulk with mix literal and literal/bind |
181 | $rs->populate([ |
182 | (+{ |
183 | url => \"'cpan.org'", |
184 | title => \['?', [ {} => "The 'best of' cpan" ] ], |
185 | }) x 5 |
186 | ]); |
187 | |
188 | is((grep { |
189 | $_->url eq 'cpan.org' && |
190 | $_->title eq "The 'best of' cpan", |
191 | } $rs->all), 5, 'populate with all literal/bind SQL'); |
192 | |
193 | $rs->delete; |
194 | |
195 | # test mixed binds with literal sql/bind |
196 | |
197 | $rs->populate([ map { +{ |
198 | url => \[ '? || ?', [ {} => 'cpan.org_' ], [ undef, $_ ] ], |
199 | title => "The 'best of' cpan", |
200 | } } (1 .. 5) ]); |
201 | |
202 | for (1 .. 5) { |
203 | ok($rs->find({ url => "cpan.org_$_" }), "Row $_ correctly created with dynamic literal/bind populate" ); |
204 | } |
205 | |
206 | $rs->delete; |
207 | } |
208 | |
84f7e8a1 |
209 | my $rs = $schema->resultset('Artist'); |
210 | $rs->delete; |
bbd6f348 |
211 | throws_ok { |
212 | $rs->populate([ |
213 | { |
214 | artistid => 1, |
215 | name => 'foo1', |
216 | }, |
217 | { |
218 | artistid => 'foo', # this dies |
219 | name => 'foo2', |
220 | }, |
221 | { |
222 | artistid => 3, |
223 | name => 'foo3', |
224 | }, |
225 | ]); |
52cef7e3 |
226 | } qr/\Qexecute_for_fetch() aborted with 'datatype mismatch\E\b/, 'bad slice'; |
bbd6f348 |
227 | |
228 | is($rs->count, 0, 'populate is atomic'); |
229 | |
1295943f |
230 | # Trying to use a column marked as a bind in the first slice with literal sql in |
231 | # a later slice should throw. |
232 | |
233 | throws_ok { |
234 | $rs->populate([ |
235 | { |
236 | artistid => 1, |
237 | name => \"'foo'", |
238 | }, |
239 | { |
240 | artistid => \2, |
241 | name => \"'foo'", |
242 | } |
243 | ]); |
f6faeab8 |
244 | } qr/Literal SQL found where a plain bind value is expected/, 'literal sql where bind expected throws'; |
1295943f |
245 | |
246 | # ... and vice-versa. |
247 | |
248 | throws_ok { |
249 | $rs->populate([ |
250 | { |
251 | artistid => \1, |
252 | name => \"'foo'", |
253 | }, |
254 | { |
255 | artistid => 2, |
256 | name => \"'foo'", |
257 | } |
258 | ]); |
f6faeab8 |
259 | } qr/\QIncorrect value (expecting SCALAR-ref/, 'bind where literal sql expected throws'; |
1295943f |
260 | |
261 | throws_ok { |
262 | $rs->populate([ |
263 | { |
264 | artistid => 1, |
265 | name => \"'foo'", |
266 | }, |
267 | { |
268 | artistid => 2, |
269 | name => \"'bar'", |
270 | } |
271 | ]); |
f6faeab8 |
272 | } qr/Inconsistent literal SQL value/, 'literal sql must be the same in all slices'; |
1295943f |
273 | |
a9bac98f |
274 | throws_ok { |
275 | $rs->populate([ |
276 | { |
277 | artistid => 1, |
278 | name => \['?', [ {} => 'foo' ] ], |
279 | }, |
280 | { |
281 | artistid => 2, |
282 | name => \"'bar'", |
283 | } |
284 | ]); |
285 | } qr/\QIncorrect value (expecting ARRAYREF-ref/, 'literal where literal+bind expected throws'; |
286 | |
287 | throws_ok { |
288 | $rs->populate([ |
289 | { |
290 | artistid => 1, |
291 | name => \['?', [ { sqlt_datatype => 'foooo' } => 'foo' ] ], |
292 | }, |
293 | { |
294 | artistid => 2, |
295 | name => \['?', [ {} => 'foo' ] ], |
296 | } |
297 | ]); |
298 | } qr/\QDiffering bind attributes on literal\/bind values not supported for column 'name'/, 'literal+bind with differing attrs throws'; |
299 | |
300 | lives_ok { |
301 | $rs->populate([ |
302 | { |
303 | artistid => 1, |
304 | name => \['?', [ undef, 'foo' ] ], |
305 | }, |
306 | { |
307 | artistid => 2, |
308 | name => \['?', [ {} => 'bar' ] ], |
309 | } |
310 | ]); |
311 | } 'literal+bind with semantically identical attrs works after normalization'; |
312 | |
75a1d824 |
313 | # test all kinds of population with stringified objects |
314 | warnings_like { |
eed5492f |
315 | local $ENV{DBIC_RT79576_NOWARN}; |
316 | |
75a1d824 |
317 | my $rs = $schema->resultset('Artist')->search({}, { columns => [qw(name rank)], order_by => 'artistid' }); |
318 | |
319 | # the stringification has nothing to do with the artist name |
320 | # this is solely for testing consistency |
321 | my $fn = Path::Class::File->new ('somedir/somefilename.tmp'); |
322 | my $fn2 = Path::Class::File->new ('somedir/someotherfilename.tmp'); |
323 | my $rank = Math::BigInt->new(42); |
324 | |
325 | my $args = { |
326 | 'stringifying objects after regular values' => [ map |
327 | { { name => $_, rank => $rank } } |
328 | ( |
329 | 'supplied before stringifying objects', |
330 | 'supplied before stringifying objects 2', |
331 | $fn, |
332 | $fn2, |
333 | ) |
334 | ], |
335 | 'stringifying objects before regular values' => [ map |
336 | { { name => $_, rank => $rank } } |
337 | ( |
338 | $fn, |
339 | $fn2, |
340 | 'supplied after stringifying objects', |
341 | 'supplied after stringifying objects 2', |
342 | ) |
343 | ], |
344 | 'stringifying objects between regular values' => [ map |
345 | { { name => $_, rank => $rank } } |
346 | ( |
347 | 'supplied before stringifying objects', |
348 | $fn, |
349 | $fn2, |
350 | 'supplied after stringifying objects', |
351 | ) |
352 | ], |
353 | 'stringifying objects around regular values' => [ map |
354 | { { name => $_, rank => $rank } } |
355 | ( |
356 | $fn, |
357 | 'supplied between stringifying objects', |
358 | $fn2, |
359 | ) |
360 | ], |
361 | }; |
362 | |
363 | local $Storable::canonical = 1; |
364 | my $preimage = nfreeze([$fn, $fn2, $rank, $args]); |
365 | |
366 | for my $tst (keys %$args) { |
367 | |
368 | # test void ctx |
369 | $rs->delete; |
370 | $rs->populate($args->{$tst}); |
371 | is_deeply( |
372 | $rs->all_hri, |
373 | $args->{$tst}, |
374 | "Populate() $tst in void context" |
375 | ); |
376 | |
377 | # test non-void ctx |
378 | $rs->delete; |
379 | my $dummy = $rs->populate($args->{$tst}); |
380 | is_deeply( |
381 | $rs->all_hri, |
382 | $args->{$tst}, |
383 | "Populate() $tst in non-void context" |
384 | ); |
385 | |
386 | # test create() as we have everything set up already |
387 | $rs->delete; |
388 | $rs->create($_) for @{$args->{$tst}}; |
389 | |
390 | is_deeply( |
391 | $rs->all_hri, |
392 | $args->{$tst}, |
393 | "Create() $tst" |
394 | ); |
395 | } |
8464d1a4 |
396 | |
75a1d824 |
397 | ok ( |
398 | ($preimage eq nfreeze( [$fn, $fn2, $rank, $args] )), |
399 | 'Arguments fed to populate()/create() unchanged' |
400 | ); |
8464d1a4 |
401 | |
75a1d824 |
402 | $rs->delete; |
403 | } [ |
404 | # warning to be removed around Apr 1st 2015 |
405 | # smokers start failing a month before that |
406 | ( |
407 | ( DBICTest::RunMode->is_author and ( time() > 1427846400 ) ) |
408 | or |
409 | ( DBICTest::RunMode->is_smoker and ( time() > 1425168000 ) ) |
410 | ) |
411 | ? () |
412 | # one unique for populate() and create() each |
413 | : (qr/\QPOSSIBLE *PAST* DATA CORRUPTION detected \E.+\QTrigger condition encountered at @{[ __FILE__ ]} line\E \d/) x 2 |
414 | ], 'Data integrity warnings as planned'; |
8464d1a4 |
415 | |
18d80024 |
416 | lives_ok { |
417 | $schema->resultset('TwoKeys')->populate([{ |
418 | artist => 1, |
419 | cd => 5, |
420 | fourkeys_to_twokeys => [{ |
421 | f_foo => 1, |
422 | f_bar => 1, |
423 | f_hello => 1, |
424 | f_goodbye => 1, |
425 | autopilot => 'a', |
426 | },{ |
427 | f_foo => 2, |
428 | f_bar => 2, |
429 | f_hello => 2, |
430 | f_goodbye => 2, |
431 | autopilot => 'b', |
432 | }] |
433 | }]) |
d6eda469 |
434 | } 'multicol-PK has_many populate works'; |
18d80024 |
435 | |
d6170b26 |
436 | lives_ok ( sub { |
437 | $schema->populate('CD', [ |
438 | {cdid => 10001, artist => $artist->id, title => 'Pretty Much Empty', year => 2011, tracks => []}, |
439 | ]) |
440 | }, 'empty has_many relationship accepted by populate'); |
441 | |
bbd6f348 |
442 | done_testing; |