9 use DBIx::Class::_Util qw(sigwarn_silencer serialize);
11 use List::Util qw/shuffle/;
14 package DBICTest::StringifiesOnly;
16 '""' => sub { $_[0]->[0] },
21 package DBICTest::StringifiesViaFallback;
23 'bool' => sub { $_[0]->[0] },
27 my $schema = DBICTest->init_schema();
29 # The map below generates stuff like:
30 # [ qw/artistid name/ ],
37 my $start_id = 'populateXaaaaaa';
41 $schema->populate('Artist', [ [ qw/artistid name/ ], map { [ ($_ + $offset) => $start_id++ ] } shuffle ( 1 .. $rows ) ] );
43 $schema->resultset ('Artist')->search ({ name => { -like => 'populateX%' } })->count,
45 'populate created correct number of rows with massive AoA bulk insert',
48 my $artist = $schema->resultset ('Artist')
49 ->search ({ 'cds.title' => { '!=', undef } }, { join => 'cds' })
51 my $ex_title = $artist->cds->first->title;
55 $schema->populate('CD', [
58 artist => $artist->id,
62 } ('Huey', 'Dewey', $ex_title, 'Louie')
64 }, qr/\Qexecute_for_fetch() aborted with '\E.+ at populate slice.+$ex_title/ms, 'Readable exception thrown for failed populate');
66 ## make sure populate honors fields/orders in list context
68 my @links = $schema->populate('Link', [
74 my $link2 = shift @links;
75 is($link2->id, 2, 'Link 2 id');
76 is($link2->url, 'burl', 'Link 2 url');
77 is($link2->title, 'btitle', 'Link 2 title');
80 @links = $schema->populate('Link', [
86 my $link3 = shift @links;
87 is($link3->id, 3, 'Link 3 id');
88 is($link3->url, 'curl', 'Link 3 url');
89 is($link3->title, 'ctitle', 'Link 3 title');
91 ## not all physical columns
92 @links = $schema->populate('Link', [
98 my $link4 = shift @links;
99 is($link4->id, 4, 'Link 4 id');
100 is($link4->url, undef, 'Link 4 url');
101 is($link4->title, 'dtitle', 'Link 4 title');
103 ## variable size dataset
104 @links = $schema->populate('Link', [
105 [ qw/id title url/ ],
107 [ 42, undef, 'url42' ],
109 is(scalar @links, 2);
110 is($links[0]->url, undef);
111 is($links[1]->url, 'url42');
113 ## make sure populate -> _insert_bulk honors fields/orders in void context
115 $schema->populate('Link', [
116 [ qw/id url title/ ],
117 [ qw/5 eurl etitle/ ]
119 my $link5 = $schema->resultset('Link')->find(5);
120 is($link5->id, 5, 'Link 5 id');
121 is($link5->url, 'eurl', 'Link 5 url');
122 is($link5->title, 'etitle', 'Link 5 title');
125 $schema->populate('Link', [
126 [ qw/id title url/ ],
127 [ qw/6 ftitle furl/ ]
129 my $link6 = $schema->resultset('Link')->find(6);
130 is($link6->id, 6, 'Link 6 id');
131 is($link6->url, 'furl', 'Link 6 url');
132 is($link6->title, 'ftitle', 'Link 6 title');
134 ## not all physical columns
135 $schema->populate('Link', [
139 my $link7 = $schema->resultset('Link')->find(7);
140 is($link7->id, 7, 'Link 7 id');
141 is($link7->url, undef, 'Link 7 url');
142 is($link7->title, 'gtitle', 'Link 7 title');
144 ## variable size dataset in void ctx
145 $schema->populate('Link', [
146 [ qw/id title url/ ],
148 [ 72, undef, 'url72' ],
150 @links = $schema->resultset('Link')->search({ id => [71, 72]}, { order_by => 'id' })->all;
151 is(scalar @links, 2);
152 is($links[0]->url, undef);
153 is($links[1]->url, 'url72');
155 ## variable size dataset in void ctx, hash version
156 $schema->populate('Link', [
158 { id => 74, title => 't74' },
159 { id => 75, url => 'u75' },
161 @links = $schema->resultset('Link')->search({ id => [73..75]}, { order_by => 'id' })->all;
162 is(scalar @links, 3);
163 is($links[0]->url, undef);
164 is($links[0]->title, undef);
165 is($links[1]->url, undef);
166 is($links[1]->title, 't74');
167 is($links[2]->url, 'u75');
168 is($links[2]->title, undef);
170 ## Make sure the void ctx trace is sane
174 [ qw/id title url/ ],
177 [ 83, undef, 'url83' ],
181 { id => 92, title => 't92' },
182 { id => 93, url => 'url93' },
185 $schema->is_executed_sql_bind(
187 $schema->populate('Link', $_);
192 'INSERT INTO link( id, title, url ) VALUES( ?, ?, ? )',
201 # populate with literals
203 my $rs = $schema->resultset('Link');
206 # test populate with all literal sql (no binds)
210 url => \"'cpan.org'",
211 title => \"'The ''best of'' cpan'",
216 $_->url eq 'cpan.org' &&
217 $_->title eq "The 'best of' cpan",
218 } $rs->all), 5, 'populate with all literal SQL');
222 # test mixed binds with literal sql
226 url => \"'cpan.org'",
227 title => "The 'best of' cpan",
232 $_->url eq 'cpan.org' &&
233 $_->title eq "The 'best of' cpan",
234 } $rs->all), 5, 'populate with all literal SQL');
239 # populate with literal+bind
241 my $rs = $schema->resultset('Link');
244 # test populate with all literal/bind sql
247 url => \['?', [ {} => 'cpan.org' ] ],
248 title => \['?', [ {} => "The 'best of' cpan" ] ],
253 $_->url eq 'cpan.org' &&
254 $_->title eq "The 'best of' cpan",
255 } $rs->all), 5, 'populate with all literal/bind');
259 # test populate with mix literal and literal/bind
262 url => \"'cpan.org'",
263 title => \['?', [ {} => "The 'best of' cpan" ] ],
268 $_->url eq 'cpan.org' &&
269 $_->title eq "The 'best of' cpan",
270 } $rs->all), 5, 'populate with all literal/bind SQL');
274 # test mixed binds with literal sql/bind
276 $rs->populate([ map { +{
277 url => \[ '? || ?', [ {} => 'cpan.org_' ], $_ ],
278 title => "The 'best of' cpan",
282 ok($rs->find({ url => "cpan.org_$_" }), "Row $_ correctly created with dynamic literal/bind populate" );
288 my $rs = $schema->resultset('Artist');
291 # this warning is correct, but we are not testing it here
292 # what we are after is the correct exception when an int
293 # fails to coerce into a sqlite rownum
294 local $SIG{__WARN__} = sigwarn_silencer( qr/datatype mismatch.+ foo as integer/ );
302 artistid => 'foo', # this dies
310 } qr/\Qexecute_for_fetch() aborted with 'datatype mismatch\E\b/, 'bad slice fails PK insert';
312 is($rs->count, 0, 'populate is atomic');
314 # Trying to use a column marked as a bind in the first slice with literal sql in
315 # a later slice should throw.
328 } qr/Literal SQL found where a plain bind value is expected/, 'literal sql where bind expected throws';
330 # ... and vice-versa.
343 } qr/\QIncorrect value (expecting SCALAR-ref/, 'bind where literal sql expected throws';
356 } qr/Inconsistent literal SQL value/, 'literal sql must be the same in all slices';
362 name => \['?', [ {} => 'foo' ] ],
369 } qr/\QIncorrect value (expecting ARRAYREF-ref/, 'literal where literal+bind expected throws';
375 name => \['?', [ { sqlt_datatype => 'foooo' } => 'foo' ] ],
379 name => \['?', [ {} => 'foo' ] ],
382 } qr/\QDiffering bind attributes on literal\/bind values not supported for column 'name'/, 'literal+bind with differing attrs throws';
388 name => \['?', [ undef, 'foo' ] ],
392 name => \['?', [ {} => 'bar' ] ],
395 } 'literal+bind with semantically identical attrs works after normalization';
397 # test all kinds of population with stringified objects
400 my $rs = $schema->resultset('Artist')->search({}, { columns => [qw(name rank)], order_by => 'artistid' });
402 # the stringification has nothing to do with the artist name
403 # this is solely for testing consistency
404 my $fn = bless [ 'somedir/somefilename.tmp' ], 'DBICTest::StringifiesOnly';
405 my $fn2 = bless [ 'somedir/someotherfilename.tmp' ], 'DBICTest::StringifiesViaFallback';
406 my $rank = Math::BigInt->new(42);
409 'stringifying objects after regular values' => { AoA => [
411 ( map { [ $_, $rank ] } (
412 'supplied before stringifying objects',
413 'supplied before stringifying objects 2',
419 'stringifying objects before regular values' => { AoA => [
421 ( map { [ $rank, $_ ] } (
424 'supplied after stringifying objects',
425 'supplied after stringifying objects 2',
429 'stringifying objects between regular values' => { AoA => [
431 ( map { [ $_, $rank ] } (
432 'supplied before stringifying objects',
435 'supplied after stringifying objects',
439 'stringifying objects around regular values' => { AoA => [
441 ( map { [ $rank, $_ ] } (
443 'supplied between stringifying objects',
448 'single stringifying object' => { AoA => [
453 'empty set' => { AoA => [
458 # generate the AoH equivalent based on the AoAs above
459 # also generate the expected HRI output ( is_deeply is too smart for its own good )
460 for my $bag (values %$args) {
462 $bag->{Expected} = [];
463 my @hdr = @{$bag->{AoA}[0]};
464 for my $v ( @{$bag->{AoA}}[1..$#{$bag->{AoA}}] ) {
465 push @{$bag->{AoH}}, my $h = {};
468 push @{$bag->{Expected}}, my $hs = {};
469 @{$hs}{@hdr} = map { "$_" } @$v;
473 local $Storable::canonical = 1;
474 my $preimage = serialize($args);
477 for my $tst (keys %$args) {
478 for my $type (qw(AoA AoH)) {
482 $rs->populate($args->{$tst}{$type});
485 $args->{$tst}{Expected},
486 "Populate() $tst in void context"
491 my $dummy = $rs->populate($args->{$tst}{$type});
494 $args->{$tst}{Expected},
495 "Populate() $tst in non-void context"
500 my @dummy = $rs->populate($args->{$tst}{$type});
503 $args->{$tst}{Expected},
504 "Populate() $tst in non-void context"
508 # test create() as we have everything set up already
510 $rs->create($_) for @{$args->{$tst}{AoH}};
514 $args->{$tst}{Expected},
520 ($preimage eq serialize($args)),
521 'Arguments fed to populate()/create() unchanged'
525 } [], 'Data integrity warnings gone as planned';
527 $schema->is_executed_sql_bind(
529 $schema->resultset('TwoKeys')->populate([{
532 fourkeys_to_twokeys => [{
549 [ 'INSERT INTO twokeys ( artist, cd)
553 [ 'INSERT INTO fourkeys_to_twokeys ( autopilot, f_bar, f_foo, f_goodbye, f_hello, t_artist, t_cd)
556 ( SELECT me.artist FROM twokeys me WHERE artist = ? AND cd = ? ),
557 ( SELECT me.cd FROM twokeys me WHERE artist = ? AND cd = ? )
564 'multicol-PK has_many populate expected trace'
568 $schema->populate('CD', [
569 {cdid => 10001, artist => $artist->id, title => 'Pretty Much Empty', year => 2011, tracks => []},
571 }, 'empty has_many relationship accepted by populate');