1 BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
11 use DBIx::Class::_Util qw(sigwarn_silencer serialize);
13 use List::Util qw/shuffle/;
16 package DBICTest::StringifiesOnly;
18 '""' => sub { $_[0]->[0] },
23 package DBICTest::StringifiesViaFallback;
25 'bool' => sub { $_[0]->[0] },
29 my $schema = DBICTest->init_schema();
31 # The map below generates stuff like:
32 # [ qw/artistid name/ ],
39 my $start_id = 'populateXaaaaaa';
43 $schema->populate('Artist', [ [ qw/artistid name/ ], map { [ ($_ + $offset) => $start_id++ ] } shuffle ( 1 .. $rows ) ] );
45 $schema->resultset ('Artist')->search ({ name => { -like => 'populateX%' } })->count,
47 'populate created correct number of rows with massive AoA bulk insert',
50 my $artist = $schema->resultset ('Artist')
51 ->search ({ 'cds.title' => { '!=', undef } }, { join => 'cds' })
53 my $ex_title = $artist->cds->first->title;
57 $schema->populate('CD', [
60 artist => $artist->id,
64 } ('Huey', 'Dewey', $ex_title, 'Louie')
66 }, qr/\Qexecute_for_fetch() aborted with '\E.+ at populate slice.+$ex_title/ms, 'Readable exception thrown for failed populate');
68 ## make sure populate honors fields/orders in list context
70 my @links = $schema->populate('Link', [
76 my $link2 = shift @links;
77 is($link2->id, 2, 'Link 2 id');
78 is($link2->url, 'burl', 'Link 2 url');
79 is($link2->title, 'btitle', 'Link 2 title');
82 @links = $schema->populate('Link', [
88 my $link3 = shift @links;
89 is($link3->id, 3, 'Link 3 id');
90 is($link3->url, 'curl', 'Link 3 url');
91 is($link3->title, 'ctitle', 'Link 3 title');
93 ## not all physical columns
94 @links = $schema->populate('Link', [
100 my $link4 = shift @links;
101 is($link4->id, 4, 'Link 4 id');
102 is($link4->url, undef, 'Link 4 url');
103 is($link4->title, 'dtitle', 'Link 4 title');
105 ## variable size dataset
106 @links = $schema->populate('Link', [
107 [ qw/id title url/ ],
109 [ 42, undef, 'url42' ],
111 is(scalar @links, 2);
112 is($links[0]->url, undef);
113 is($links[1]->url, 'url42');
115 ## make sure populate -> _insert_bulk honors fields/orders in void context
117 $schema->populate('Link', [
118 [ qw/id url title/ ],
119 [ qw/5 eurl etitle/ ]
121 my $link5 = $schema->resultset('Link')->find(5);
122 is($link5->id, 5, 'Link 5 id');
123 is($link5->url, 'eurl', 'Link 5 url');
124 is($link5->title, 'etitle', 'Link 5 title');
127 $schema->populate('Link', [
128 [ qw/id title url/ ],
129 [ qw/6 ftitle furl/ ]
131 my $link6 = $schema->resultset('Link')->find(6);
132 is($link6->id, 6, 'Link 6 id');
133 is($link6->url, 'furl', 'Link 6 url');
134 is($link6->title, 'ftitle', 'Link 6 title');
136 ## not all physical columns
137 $schema->populate('Link', [
141 my $link7 = $schema->resultset('Link')->find(7);
142 is($link7->id, 7, 'Link 7 id');
143 is($link7->url, undef, 'Link 7 url');
144 is($link7->title, 'gtitle', 'Link 7 title');
146 ## variable size dataset in void ctx
147 $schema->populate('Link', [
148 [ qw/id title url/ ],
150 [ 72, undef, 'url72' ],
152 @links = $schema->resultset('Link')->search({ id => [71, 72]}, { order_by => 'id' })->all;
153 is(scalar @links, 2);
154 is($links[0]->url, undef);
155 is($links[1]->url, 'url72');
157 ## variable size dataset in void ctx, hash version
158 $schema->populate('Link', [
160 { id => 74, title => 't74' },
161 { id => 75, url => 'u75' },
163 @links = $schema->resultset('Link')->search({ id => [73..75]}, { order_by => 'id' })->all;
164 is(scalar @links, 3);
165 is($links[0]->url, undef);
166 is($links[0]->title, undef);
167 is($links[1]->url, undef);
168 is($links[1]->title, 't74');
169 is($links[2]->url, 'u75');
170 is($links[2]->title, undef);
172 ## Make sure the void ctx trace is sane
176 [ qw/id title url/ ],
179 [ 83, undef, 'url83' ],
183 { id => 92, title => 't92' },
184 { id => 93, url => 'url93' },
187 $schema->is_executed_sql_bind(
189 $schema->populate('Link', $_);
194 'INSERT INTO link( id, title, url ) VALUES( ?, ?, ? )',
203 # populate with literals
205 my $rs = $schema->resultset('Link');
208 # test populate with all literal sql (no binds)
212 url => \"'cpan.org'",
213 title => \"'The ''best of'' cpan'",
218 $_->url eq 'cpan.org' &&
219 $_->title eq "The 'best of' cpan",
220 } $rs->all), 5, 'populate with all literal SQL');
224 # test mixed binds with literal sql
228 url => \"'cpan.org'",
229 title => "The 'best of' cpan",
234 $_->url eq 'cpan.org' &&
235 $_->title eq "The 'best of' cpan",
236 } $rs->all), 5, 'populate with all literal SQL');
241 # populate with literal+bind
243 my $rs = $schema->resultset('Link');
246 # test populate with all literal/bind sql
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');
261 # test populate with mix literal and literal/bind
264 url => \"'cpan.org'",
265 title => \['?', [ {} => "The 'best of' cpan" ] ],
270 $_->url eq 'cpan.org' &&
271 $_->title eq "The 'best of' cpan",
272 } $rs->all), 5, 'populate with all literal/bind SQL');
276 # test mixed binds with literal sql/bind
278 $rs->populate([ map { +{
279 url => \[ '? || ?', [ {} => 'cpan.org_' ], $_ ],
280 title => "The 'best of' cpan",
284 ok($rs->find({ url => "cpan.org_$_" }), "Row $_ correctly created with dynamic literal/bind populate" );
290 my $rs = $schema->resultset('Artist');
293 # this warning is correct, but we are not testing it here
294 # what we are after is the correct exception when an int
295 # fails to coerce into a sqlite rownum
296 local $SIG{__WARN__} = sigwarn_silencer( qr/datatype mismatch.+ foo as integer/ );
304 artistid => 'foo', # this dies
312 } qr/\Qexecute_for_fetch() aborted with 'datatype mismatch\E\b/, 'bad slice fails PK insert';
314 is($rs->count, 0, 'populate is atomic');
316 # Trying to use a column marked as a bind in the first slice with literal sql in
317 # a later slice should throw.
330 } qr/Literal SQL found where a plain bind value is expected/, 'literal sql where bind expected throws';
332 # ... and vice-versa.
345 } qr/\QIncorrect value (expecting SCALAR-ref/, 'bind where literal sql expected throws';
358 } qr/Inconsistent literal SQL value/, 'literal sql must be the same in all slices';
364 name => \['?', [ {} => 'foo' ] ],
371 } qr/\QIncorrect value (expecting ARRAYREF-ref/, 'literal where literal+bind expected throws';
377 name => \['?', [ { sqlt_datatype => 'foooo' } => 'foo' ] ],
381 name => \['?', [ {} => 'foo' ] ],
384 } qr/\QDiffering bind attributes on literal\/bind values not supported for column 'name'/, 'literal+bind with differing attrs throws';
390 name => \['?', [ undef, 'foo' ] ],
394 name => \['?', [ {} => 'bar' ] ],
397 } 'literal+bind with semantically identical attrs works after normalization';
399 # test all kinds of population with stringified objects
402 my $rs = $schema->resultset('Artist')->search({}, { columns => [qw(name rank)], order_by => 'artistid' });
404 # the stringification has nothing to do with the artist name
405 # this is solely for testing consistency
406 my $fn = bless [ 'somedir/somefilename.tmp' ], 'DBICTest::StringifiesOnly';
407 my $fn2 = bless [ 'somedir/someotherfilename.tmp' ], 'DBICTest::StringifiesViaFallback';
408 my $rank = Math::BigInt->new(42);
411 'stringifying objects after regular values' => { AoA => [
413 ( map { [ $_, $rank ] } (
414 'supplied before stringifying objects',
415 'supplied before stringifying objects 2',
421 'stringifying objects before regular values' => { AoA => [
423 ( map { [ $rank, $_ ] } (
426 'supplied after stringifying objects',
427 'supplied after stringifying objects 2',
431 'stringifying objects between regular values' => { AoA => [
433 ( map { [ $_, $rank ] } (
434 'supplied before stringifying objects',
437 'supplied after stringifying objects',
441 'stringifying objects around regular values' => { AoA => [
443 ( map { [ $rank, $_ ] } (
445 'supplied between stringifying objects',
450 'single stringifying object' => { AoA => [
455 'empty set' => { AoA => [
460 # generate the AoH equivalent based on the AoAs above
461 # also generate the expected HRI output ( is_deeply is too smart for its own good )
462 for my $bag (values %$args) {
464 $bag->{Expected} = [];
465 my @hdr = @{$bag->{AoA}[0]};
466 for my $v ( @{$bag->{AoA}}[1..$#{$bag->{AoA}}] ) {
467 push @{$bag->{AoH}}, my $h = {};
470 push @{$bag->{Expected}}, my $hs = {};
471 @{$hs}{@hdr} = map { "$_" } @$v;
475 local $Storable::canonical = 1;
476 my $preimage = serialize($args);
479 for my $tst (keys %$args) {
480 for my $type (qw(AoA AoH)) {
484 $rs->populate($args->{$tst}{$type});
487 $args->{$tst}{Expected},
488 "Populate() $tst in void context"
493 my $dummy = $rs->populate($args->{$tst}{$type});
496 $args->{$tst}{Expected},
497 "Populate() $tst in non-void context"
502 my @dummy = $rs->populate($args->{$tst}{$type});
505 $args->{$tst}{Expected},
506 "Populate() $tst in non-void context"
510 # test create() as we have everything set up already
512 $rs->create($_) for @{$args->{$tst}{AoH}};
516 $args->{$tst}{Expected},
522 ($preimage eq serialize($args)),
523 'Arguments fed to populate()/create() unchanged'
527 } [], 'Data integrity warnings gone as planned';
529 $schema->is_executed_sql_bind(
531 $schema->resultset('TwoKeys')->populate([{
534 fourkeys_to_twokeys => [{
551 [ 'INSERT INTO twokeys ( artist, cd)
555 [ 'INSERT INTO fourkeys_to_twokeys ( autopilot, f_bar, f_foo, f_goodbye, f_hello, t_artist, t_cd)
558 ( SELECT me.artist FROM twokeys me WHERE artist = ? AND cd = ? ),
559 ( SELECT me.cd FROM twokeys me WHERE artist = ? AND cd = ? )
566 'multicol-PK has_many populate expected trace'
570 $schema->populate('CD', [
571 {cdid => 10001, artist => $artist->id, title => 'Pretty Much Empty', year => 2011, tracks => []},
573 }, 'empty has_many relationship accepted by populate');