Fix missing true return lost during e5a62c46f
[dbsrgits/DBIx-Class.git] / t / 100populate.t
CommitLineData
54e0bd06 1use strict;
d35a6fed 2use warnings;
54e0bd06 3
4use Test::More;
d35a6fed 5use Test::Exception;
75a1d824 6use Test::Warn;
54e0bd06 7use lib qw(t/lib);
8use DBICTest;
a4c52abc 9use DBIx::Class::_Util 'sigwarn_silencer';
c0d8cb1f 10use Path::Class::File ();
75a1d824 11use Math::BigInt;
569b9fe6 12use List::Util qw/shuffle/;
75a1d824 13use Storable qw/nfreeze dclone/;
54e0bd06 14
54e0bd06 15my $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
25my $start_id = 'populateXaaaaaa';
569b9fe6 26my $rows = 10_000;
d35a6fed 27my $offset = 3;
28
569b9fe6 29$schema->populate('Artist', [ [ qw/artistid name/ ], map { [ ($_ + $offset) => $start_id++ ] } shuffle ( 1 .. $rows ) ] );
d35a6fed 30is (
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
36my $artist = $schema->resultset ('Artist')
37 ->search ({ 'cds.title' => { '!=', undef } }, { join => 'cds' })
38 ->first;
39my $ex_title = $artist->cds->first->title;
40
41throws_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 56my @links = $schema->populate('Link', [
b0457415 57[ qw/id url title/ ],
58[ qw/2 burl btitle/ ]
59]);
89b2e3e4 60is(scalar @links, 1);
61
62my $link2 = shift @links;
b0457415 63is($link2->id, 2, 'Link 2 id');
64is($link2->url, 'burl', 'Link 2 url');
65is($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 72is(scalar @links, 1);
73
74my $link3 = shift @links;
b0457415 75is($link3->id, 3, 'Link 3 id');
76is($link3->url, 'curl', 'Link 3 url');
77is($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 84is(scalar @links, 1);
85
86my $link4 = shift @links;
b0457415 87is($link4->id, 4, 'Link 4 id');
88is($link4->url, undef, 'Link 4 url');
89is($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]);
98my $link5 = $schema->resultset('Link')->find(5);
99is($link5->id, 5, 'Link 5 id');
100is($link5->url, 'eurl', 'Link 5 url');
101is($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]);
108my $link6 = $schema->resultset('Link')->find(6);
109is($link6->id, 6, 'Link 6 id');
110is($link6->url, 'furl', 'Link 6 url');
111is($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]);
118my $link7 = $schema->resultset('Link')->find(7);
119is($link7->id, 7, 'Link 7 id');
120is($link7->url, undef, 'Link 7 url');
121is($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 210my $rs = $schema->resultset('Artist');
211$rs->delete;
bbd6f348 212throws_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
234is($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
239throws_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
254throws_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
267throws_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 280throws_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
293throws_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
306lives_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
320warnings_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 422lives_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 442lives_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 448done_testing;