9 use DBIx::Class::_Util qw(sigwarn_silencer serialize);
10 use Path::Class::File ();
12 use List::Util qw/shuffle/;
14 my $schema = DBICTest->init_schema();
16 # The map below generates stuff like:
17 # [ qw/artistid name/ ],
24 my $start_id = 'populateXaaaaaa';
28 $schema->populate('Artist', [ [ qw/artistid name/ ], map { [ ($_ + $offset) => $start_id++ ] } shuffle ( 1 .. $rows ) ] );
30 $schema->resultset ('Artist')->search ({ name => { -like => 'populateX%' } })->count,
32 'populate created correct number of rows with massive AoA bulk insert',
35 my $artist = $schema->resultset ('Artist')
36 ->search ({ 'cds.title' => { '!=', undef } }, { join => 'cds' })
38 my $ex_title = $artist->cds->first->title;
42 $schema->populate('CD', [
45 artist => $artist->id,
49 } ('Huey', 'Dewey', $ex_title, 'Louie')
51 }, qr/\Qexecute_for_fetch() aborted with '\E.+ at populate slice.+$ex_title/ms, 'Readable exception thrown for failed populate');
53 ## make sure populate honors fields/orders in list context
55 my @links = $schema->populate('Link', [
61 my $link2 = shift @links;
62 is($link2->id, 2, 'Link 2 id');
63 is($link2->url, 'burl', 'Link 2 url');
64 is($link2->title, 'btitle', 'Link 2 title');
67 @links = $schema->populate('Link', [
73 my $link3 = shift @links;
74 is($link3->id, 3, 'Link 3 id');
75 is($link3->url, 'curl', 'Link 3 url');
76 is($link3->title, 'ctitle', 'Link 3 title');
78 ## not all physical columns
79 @links = $schema->populate('Link', [
85 my $link4 = shift @links;
86 is($link4->id, 4, 'Link 4 id');
87 is($link4->url, undef, 'Link 4 url');
88 is($link4->title, 'dtitle', 'Link 4 title');
90 ## variable size dataset
91 @links = $schema->populate('Link', [
94 [ 42, undef, 'url42' ],
97 is($links[0]->url, undef);
98 is($links[1]->url, 'url42');
100 ## make sure populate -> _insert_bulk honors fields/orders in void context
102 $schema->populate('Link', [
103 [ qw/id url title/ ],
104 [ qw/5 eurl etitle/ ]
106 my $link5 = $schema->resultset('Link')->find(5);
107 is($link5->id, 5, 'Link 5 id');
108 is($link5->url, 'eurl', 'Link 5 url');
109 is($link5->title, 'etitle', 'Link 5 title');
112 $schema->populate('Link', [
113 [ qw/id title url/ ],
114 [ qw/6 ftitle furl/ ]
116 my $link6 = $schema->resultset('Link')->find(6);
117 is($link6->id, 6, 'Link 6 id');
118 is($link6->url, 'furl', 'Link 6 url');
119 is($link6->title, 'ftitle', 'Link 6 title');
121 ## not all physical columns
122 $schema->populate('Link', [
126 my $link7 = $schema->resultset('Link')->find(7);
127 is($link7->id, 7, 'Link 7 id');
128 is($link7->url, undef, 'Link 7 url');
129 is($link7->title, 'gtitle', 'Link 7 title');
131 ## variable size dataset in void ctx
132 $schema->populate('Link', [
133 [ qw/id title url/ ],
135 [ 72, undef, 'url72' ],
137 @links = $schema->resultset('Link')->search({ id => [71, 72]}, { order_by => 'id' })->all;
138 is(scalar @links, 2);
139 is($links[0]->url, undef);
140 is($links[1]->url, 'url72');
142 ## variable size dataset in void ctx, hash version
143 $schema->populate('Link', [
145 { id => 74, title => 't74' },
146 { id => 75, url => 'u75' },
148 @links = $schema->resultset('Link')->search({ id => [73..75]}, { order_by => 'id' })->all;
149 is(scalar @links, 3);
150 is($links[0]->url, undef);
151 is($links[0]->title, undef);
152 is($links[1]->url, undef);
153 is($links[1]->title, 't74');
154 is($links[2]->url, 'u75');
155 is($links[2]->title, undef);
157 ## Make sure the void ctx trace is sane
161 [ qw/id title url/ ],
164 [ 83, undef, 'url83' ],
168 { id => 92, title => 't92' },
169 { id => 93, url => 'url93' },
172 $schema->is_executed_sql_bind(
174 $schema->populate('Link', $_);
179 'INSERT INTO link( id, title, url ) VALUES( ?, ?, ? )',
188 # populate with literals
190 my $rs = $schema->resultset('Link');
193 # test populate with all literal sql (no binds)
197 url => \"'cpan.org'",
198 title => \"'The ''best of'' cpan'",
203 $_->url eq 'cpan.org' &&
204 $_->title eq "The 'best of' cpan",
205 } $rs->all), 5, 'populate with all literal SQL');
209 # test mixed binds with literal sql
213 url => \"'cpan.org'",
214 title => "The 'best of' cpan",
219 $_->url eq 'cpan.org' &&
220 $_->title eq "The 'best of' cpan",
221 } $rs->all), 5, 'populate with all literal SQL');
226 # populate with literal+bind
228 my $rs = $schema->resultset('Link');
231 # test populate with all literal/bind sql
234 url => \['?', [ {} => 'cpan.org' ] ],
235 title => \['?', [ {} => "The 'best of' cpan" ] ],
240 $_->url eq 'cpan.org' &&
241 $_->title eq "The 'best of' cpan",
242 } $rs->all), 5, 'populate with all literal/bind');
246 # test populate with mix literal and literal/bind
249 url => \"'cpan.org'",
250 title => \['?', [ {} => "The 'best of' cpan" ] ],
255 $_->url eq 'cpan.org' &&
256 $_->title eq "The 'best of' cpan",
257 } $rs->all), 5, 'populate with all literal/bind SQL');
261 # test mixed binds with literal sql/bind
263 $rs->populate([ map { +{
264 url => \[ '? || ?', [ {} => 'cpan.org_' ], $_ ],
265 title => "The 'best of' cpan",
269 ok($rs->find({ url => "cpan.org_$_" }), "Row $_ correctly created with dynamic literal/bind populate" );
275 my $rs = $schema->resultset('Artist');
278 # this warning is correct, but we are not testing it here
279 # what we are after is the correct exception when an int
280 # fails to coerce into a sqlite rownum
281 local $SIG{__WARN__} = sigwarn_silencer( qr/datatype mismatch.+ foo as integer/ );
289 artistid => 'foo', # this dies
297 } qr/\Qexecute_for_fetch() aborted with 'datatype mismatch\E\b/, 'bad slice fails PK insert';
299 is($rs->count, 0, 'populate is atomic');
301 # Trying to use a column marked as a bind in the first slice with literal sql in
302 # a later slice should throw.
315 } qr/Literal SQL found where a plain bind value is expected/, 'literal sql where bind expected throws';
317 # ... and vice-versa.
330 } qr/\QIncorrect value (expecting SCALAR-ref/, 'bind where literal sql expected throws';
343 } qr/Inconsistent literal SQL value/, 'literal sql must be the same in all slices';
349 name => \['?', [ {} => 'foo' ] ],
356 } qr/\QIncorrect value (expecting ARRAYREF-ref/, 'literal where literal+bind expected throws';
362 name => \['?', [ { sqlt_datatype => 'foooo' } => 'foo' ] ],
366 name => \['?', [ {} => 'foo' ] ],
369 } qr/\QDiffering bind attributes on literal\/bind values not supported for column 'name'/, 'literal+bind with differing attrs throws';
375 name => \['?', [ undef, 'foo' ] ],
379 name => \['?', [ {} => 'bar' ] ],
382 } 'literal+bind with semantically identical attrs works after normalization';
384 # test all kinds of population with stringified objects
387 local $ENV{DBIC_RT79576_NOWARN};
389 my $rs = $schema->resultset('Artist')->search({}, { columns => [qw(name rank)], order_by => 'artistid' });
391 # the stringification has nothing to do with the artist name
392 # this is solely for testing consistency
393 my $fn = Path::Class::File->new ('somedir/somefilename.tmp');
394 my $fn2 = Path::Class::File->new ('somedir/someotherfilename.tmp');
395 my $rank = Math::BigInt->new(42);
398 'stringifying objects after regular values' => { AoA => [
400 ( map { [ $_, $rank ] } (
401 'supplied before stringifying objects',
402 'supplied before stringifying objects 2',
408 'stringifying objects before regular values' => { AoA => [
410 ( map { [ $rank, $_ ] } (
413 'supplied after stringifying objects',
414 'supplied after stringifying objects 2',
418 'stringifying objects between regular values' => { AoA => [
420 ( map { [ $_, $rank ] } (
421 'supplied before stringifying objects',
424 'supplied after stringifying objects',
428 'stringifying objects around regular values' => { AoA => [
430 ( map { [ $rank, $_ ] } (
432 'supplied between stringifying objects',
437 'single stringifying object' => { AoA => [
442 'empty set' => { AoA => [
447 # generate the AoH equivalent based on the AoAs above
448 for my $bag (values %$args) {
450 my @hdr = @{$bag->{AoA}[0]};
451 for my $v ( @{$bag->{AoA}}[1..$#{$bag->{AoA}}] ) {
452 push @{$bag->{AoH}}, my $h = {};
457 local $Storable::canonical = 1;
458 my $preimage = serialize($args);
461 for my $tst (keys %$args) {
462 for my $type (qw(AoA AoH)) {
466 $rs->populate($args->{$tst}{$type});
470 "Populate() $tst in void context"
475 my $dummy = $rs->populate($args->{$tst}{$type});
479 "Populate() $tst in non-void context"
484 my @dummy = $rs->populate($args->{$tst}{$type});
488 "Populate() $tst in non-void context"
492 # test create() as we have everything set up already
494 $rs->create($_) for @{$args->{$tst}{AoH}};
504 ($preimage eq serialize($args)),
505 'Arguments fed to populate()/create() unchanged'
510 # warning to be removed around Apr 1st 2015
511 # smokers start failing a month before that
513 ( DBICTest::RunMode->is_author and ( time() > 1427846400 ) )
515 ( DBICTest::RunMode->is_smoker and ( time() > 1425168000 ) )
518 # one unique for populate() and create() each
519 : (qr/\QPOSSIBLE *PAST* DATA CORRUPTION detected \E.+\QTrigger condition encountered at @{[ __FILE__ ]} line\E \d/) x 4
520 ], 'Data integrity warnings as planned';
522 $schema->is_executed_sql_bind(
524 $schema->resultset('TwoKeys')->populate([{
527 fourkeys_to_twokeys => [{
544 [ 'INSERT INTO twokeys ( artist, cd)
548 [ 'INSERT INTO fourkeys_to_twokeys ( autopilot, f_bar, f_foo, f_goodbye, f_hello, t_artist, t_cd)
551 ( SELECT me.artist FROM twokeys me WHERE artist = ? AND cd = ? ),
552 ( SELECT me.cd FROM twokeys me WHERE artist = ? AND cd = ? )
559 'multicol-PK has_many populate expected trace'
563 $schema->populate('CD', [
564 {cdid => 10001, artist => $artist->id, title => 'Pretty Much Empty', year => 2011, tracks => []},
566 }, 'empty has_many relationship accepted by populate');