More robust behavior of ANFANG.pm, also guard against sitecustomize.pl
[dbsrgits/DBIx-Class.git] / t / 100populate.t
1 BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
2
3 use strict;
4 use warnings;
5
6 use Test::More;
7 use Test::Exception;
8 use Test::Warn;
9
10 use DBICTest;
11 use DBIx::Class::_Util qw(sigwarn_silencer serialize);
12 use Math::BigInt;
13 use List::Util qw/shuffle/;
14
15 {
16   package DBICTest::StringifiesOnly;
17   use overload
18     '""' => sub { $_[0]->[0] },
19     fallback => 0,
20   ;
21 }
22 {
23   package DBICTest::StringifiesViaFallback;
24   use overload
25     'bool' => sub { $_[0]->[0] },
26   ;
27 }
28
29 my $schema = DBICTest->init_schema();
30
31 # The map below generates stuff like:
32 #   [ qw/artistid name/ ],
33 #   [ 4, "b" ],
34 #   [ 5, "c" ],
35 #   ...
36 #   [ 9999, "ntm" ],
37 #   [ 10000, "ntn" ],
38
39 my $start_id = 'populateXaaaaaa';
40 my $rows = 10_000;
41 my $offset = 3;
42
43 $schema->populate('Artist', [ [ qw/artistid name/ ], map { [ ($_ + $offset) => $start_id++ ] } shuffle ( 1 .. $rows ) ] );
44 is (
45     $schema->resultset ('Artist')->search ({ name => { -like => 'populateX%' } })->count,
46     $rows,
47     'populate created correct number of rows with massive AoA bulk insert',
48 );
49
50 my $artist = $schema->resultset ('Artist')
51               ->search ({ 'cds.title' => { '!=', undef } }, { join => 'cds' })
52                 ->first;
53 my $ex_title = $artist->cds->first->title;
54
55 throws_ok ( sub {
56   my $i = 600;
57   $schema->populate('CD', [
58     map {
59       {
60         artist => $artist->id,
61         title => $_,
62         year => 2009,
63       }
64     } ('Huey', 'Dewey', $ex_title, 'Louie')
65   ])
66 }, qr/\Qexecute_for_fetch() aborted with '\E.+ at populate slice.+$ex_title/ms, 'Readable exception thrown for failed populate');
67
68 ## make sure populate honors fields/orders in list context
69 ## schema order
70 my @links = $schema->populate('Link', [
71 [ qw/id url title/ ],
72 [ qw/2 burl btitle/ ]
73 ]);
74 is(scalar @links, 1);
75
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');
80
81 ## non-schema order
82 @links = $schema->populate('Link', [
83 [ qw/id title url/ ],
84 [ qw/3 ctitle curl/ ]
85 ]);
86 is(scalar @links, 1);
87
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');
92
93 ## not all physical columns
94 @links = $schema->populate('Link', [
95 [ qw/id title/ ],
96 [ qw/4 dtitle/ ]
97 ]);
98 is(scalar @links, 1);
99
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');
104
105 ## variable size dataset
106 @links = $schema->populate('Link', [
107 [ qw/id title url/ ],
108 [ 41 ],
109 [ 42, undef, 'url42' ],
110 ]);
111 is(scalar @links, 2);
112 is($links[0]->url, undef);
113 is($links[1]->url, 'url42');
114
115 ## make sure populate -> _insert_bulk honors fields/orders in void context
116 ## schema order
117 $schema->populate('Link', [
118 [ qw/id url title/ ],
119 [ qw/5 eurl etitle/ ]
120 ]);
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');
125
126 ## non-schema order
127 $schema->populate('Link', [
128 [ qw/id title url/ ],
129 [ qw/6 ftitle furl/ ]
130 ]);
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');
135
136 ## not all physical columns
137 $schema->populate('Link', [
138 [ qw/id title/ ],
139 [ qw/7 gtitle/ ]
140 ]);
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');
145
146 ## variable size dataset in void ctx
147 $schema->populate('Link', [
148 [ qw/id title url/ ],
149 [ 71 ],
150 [ 72, undef, 'url72' ],
151 ]);
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');
156
157 ## variable size dataset in void ctx, hash version
158 $schema->populate('Link', [
159   { id => 73 },
160   { id => 74, title => 't74' },
161   { id => 75, url => 'u75' },
162 ]);
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);
171
172 ## Make sure the void ctx trace is sane
173 {
174   for (
175     [
176       [ qw/id title url/ ],
177       [ 81 ],
178       [ 82, 't82' ],
179       [ 83, undef, 'url83' ],
180     ],
181     [
182       { id => 91 },
183       { id => 92, title => 't92' },
184       { id => 93, url => 'url93' },
185     ]
186   ) {
187     $schema->is_executed_sql_bind(
188       sub {
189         $schema->populate('Link', $_);
190       },
191       [
192         [ 'BEGIN' ],
193         [
194           'INSERT INTO link( id, title, url ) VALUES( ?, ?, ? )',
195           "__BULK_INSERT__"
196         ],
197         [ 'COMMIT' ],
198       ]
199     );
200   }
201 }
202
203 # populate with literals
204 {
205   my $rs = $schema->resultset('Link');
206   $rs->delete;
207
208   # test populate with all literal sql (no binds)
209
210   $rs->populate([
211     (+{
212         url => \"'cpan.org'",
213         title => \"'The ''best of'' cpan'",
214     }) x 5
215   ]);
216
217   is((grep {
218     $_->url eq 'cpan.org' &&
219     $_->title eq "The 'best of' cpan",
220   } $rs->all), 5, 'populate with all literal SQL');
221
222   $rs->delete;
223
224   # test mixed binds with literal sql
225
226   $rs->populate([
227     (+{
228         url => \"'cpan.org'",
229         title => "The 'best of' cpan",
230     }) x 5
231   ]);
232
233   is((grep {
234     $_->url eq 'cpan.org' &&
235     $_->title eq "The 'best of' cpan",
236   } $rs->all), 5, 'populate with all literal SQL');
237
238   $rs->delete;
239 }
240
241 # populate with literal+bind
242 {
243   my $rs = $schema->resultset('Link');
244   $rs->delete;
245
246   # test populate with all literal/bind sql
247   $rs->populate([
248     (+{
249         url => \['?', [ {} => 'cpan.org' ] ],
250         title => \['?', [ {} => "The 'best of' cpan" ] ],
251     }) x 5
252   ]);
253
254   is((grep {
255     $_->url eq 'cpan.org' &&
256     $_->title eq "The 'best of' cpan",
257   } $rs->all), 5, 'populate with all literal/bind');
258
259   $rs->delete;
260
261   # test populate with mix literal and literal/bind
262   $rs->populate([
263     (+{
264         url => \"'cpan.org'",
265         title => \['?', [ {} => "The 'best of' cpan" ] ],
266     }) x 5
267   ]);
268
269   is((grep {
270     $_->url eq 'cpan.org' &&
271     $_->title eq "The 'best of' cpan",
272   } $rs->all), 5, 'populate with all literal/bind SQL');
273
274   $rs->delete;
275
276   # test mixed binds with literal sql/bind
277
278   $rs->populate([ map { +{
279     url => \[ '? || ?', [ {} => 'cpan.org_' ], $_ ],
280     title => "The 'best of' cpan",
281   } } (1 .. 5) ]);
282
283   for (1 .. 5) {
284     ok($rs->find({ url => "cpan.org_$_" }), "Row $_ correctly created with dynamic literal/bind populate" );
285   }
286
287   $rs->delete;
288 }
289
290 my $rs = $schema->resultset('Artist');
291 $rs->delete;
292 throws_ok {
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/ );
297
298     $rs->populate([
299         {
300             artistid => 1,
301             name => 'foo1',
302         },
303         {
304             artistid => 'foo', # this dies
305             name => 'foo2',
306         },
307         {
308             artistid => 3,
309             name => 'foo3',
310         },
311     ]);
312 } qr/\Qexecute_for_fetch() aborted with 'datatype mismatch\E\b/, 'bad slice fails PK insert';
313
314 is($rs->count, 0, 'populate is atomic');
315
316 # Trying to use a column marked as a bind in the first slice with literal sql in
317 # a later slice should throw.
318
319 throws_ok {
320   $rs->populate([
321     {
322       artistid => 1,
323       name => \"'foo'",
324     },
325     {
326       artistid => \2,
327       name => \"'foo'",
328     }
329   ]);
330 } qr/Literal SQL found where a plain bind value is expected/, 'literal sql where bind expected throws';
331
332 # ... and vice-versa.
333
334 throws_ok {
335   $rs->populate([
336     {
337       artistid => \1,
338       name => \"'foo'",
339     },
340     {
341       artistid => 2,
342       name => \"'foo'",
343     }
344   ]);
345 } qr/\QIncorrect value (expecting SCALAR-ref/, 'bind where literal sql expected throws';
346
347 throws_ok {
348   $rs->populate([
349     {
350       artistid => 1,
351       name => \"'foo'",
352     },
353     {
354       artistid => 2,
355       name => \"'bar'",
356     }
357   ]);
358 } qr/Inconsistent literal SQL value/, 'literal sql must be the same in all slices';
359
360 throws_ok {
361   $rs->populate([
362     {
363       artistid => 1,
364       name => \['?', [ {} => 'foo' ] ],
365     },
366     {
367       artistid => 2,
368       name => \"'bar'",
369     }
370   ]);
371 } qr/\QIncorrect value (expecting ARRAYREF-ref/, 'literal where literal+bind expected throws';
372
373 throws_ok {
374   $rs->populate([
375     {
376       artistid => 1,
377       name => \['?', [ { sqlt_datatype => 'foooo' } => 'foo' ] ],
378     },
379     {
380       artistid => 2,
381       name => \['?', [ {} => 'foo' ] ],
382     }
383   ]);
384 } qr/\QDiffering bind attributes on literal\/bind values not supported for column 'name'/, 'literal+bind with differing attrs throws';
385
386 lives_ok {
387   $rs->populate([
388     {
389       artistid => 1,
390       name => \['?', [ undef, 'foo' ] ],
391     },
392     {
393       artistid => 2,
394       name => \['?', [ {} => 'bar' ] ],
395     }
396   ]);
397 } 'literal+bind with semantically identical attrs works after normalization';
398
399 # test all kinds of population with stringified objects
400 # or with empty sets
401 warnings_like {
402   my $rs = $schema->resultset('Artist')->search({}, { columns => [qw(name rank)], order_by => 'artistid' });
403
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);
409
410   my $args = {
411     'stringifying objects after regular values' => { AoA => [
412       [qw( name rank )],
413       ( map { [ $_, $rank ] } (
414         'supplied before stringifying objects',
415         'supplied before stringifying objects 2',
416         $fn,
417         $fn2,
418       )),
419     ]},
420
421     'stringifying objects before regular values' => { AoA => [
422       [qw( rank name )],
423       ( map { [ $rank, $_ ] } (
424         $fn,
425         $fn2,
426         'supplied after stringifying objects',
427         'supplied after stringifying objects 2',
428       )),
429     ]},
430
431     'stringifying objects between regular values' => { AoA => [
432       [qw( name rank )],
433       ( map { [ $_, $rank ] } (
434         'supplied before stringifying objects',
435         $fn,
436         $fn2,
437         'supplied after stringifying objects',
438       ))
439     ]},
440
441     'stringifying objects around regular values' => { AoA => [
442       [qw( rank name )],
443       ( map { [ $rank, $_ ] } (
444         $fn,
445         'supplied between stringifying objects',
446         $fn2,
447       ))
448     ]},
449
450     'single stringifying object' => { AoA => [
451       [qw( rank name )],
452       [ $rank, $fn ],
453     ]},
454
455     'empty set' => { AoA => [
456       [qw( name rank )],
457     ]},
458   };
459
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) {
463     $bag->{AoH} = [];
464     $bag->{Expected} = [];
465     my @hdr = @{$bag->{AoA}[0]};
466     for my $v ( @{$bag->{AoA}}[1..$#{$bag->{AoA}}] ) {
467       push @{$bag->{AoH}}, my $h = {};
468       @{$h}{@hdr} = @$v;
469
470       push @{$bag->{Expected}}, my $hs = {};
471       @{$hs}{@hdr} = map { "$_" } @$v;
472     }
473   }
474
475   local $Storable::canonical = 1;
476   my $preimage = serialize($args);
477
478
479   for my $tst (keys %$args) {
480     for my $type (qw(AoA AoH)) {
481
482       # test void ctx
483       $rs->delete;
484       $rs->populate($args->{$tst}{$type});
485       is_deeply(
486         $rs->all_hri,
487         $args->{$tst}{Expected},
488         "Populate() $tst in void context"
489       );
490
491       # test scalar ctx
492       $rs->delete;
493       my $dummy = $rs->populate($args->{$tst}{$type});
494       is_deeply(
495         $rs->all_hri,
496         $args->{$tst}{Expected},
497         "Populate() $tst in non-void context"
498       );
499
500       # test list ctx
501       $rs->delete;
502       my @dummy = $rs->populate($args->{$tst}{$type});
503       is_deeply(
504         $rs->all_hri,
505         $args->{$tst}{Expected},
506         "Populate() $tst in non-void context"
507       );
508     }
509
510     # test create() as we have everything set up already
511     $rs->delete;
512     $rs->create($_) for @{$args->{$tst}{AoH}};
513
514     is_deeply(
515       $rs->all_hri,
516       $args->{$tst}{Expected},
517       "Create() $tst"
518     );
519   }
520
521   ok (
522     ($preimage eq serialize($args)),
523     'Arguments fed to populate()/create() unchanged'
524   );
525
526   $rs->delete;
527 } [], 'Data integrity warnings gone as planned';
528
529 $schema->is_executed_sql_bind(
530   sub {
531    $schema->resultset('TwoKeys')->populate([{
532       artist => 1,
533       cd     => 5,
534       fourkeys_to_twokeys => [{
535             f_foo => 1,
536             f_bar => 1,
537             f_hello => 1,
538             f_goodbye => 1,
539             autopilot => 'a',
540       },{
541             f_foo => 2,
542             f_bar => 2,
543             f_hello => 2,
544             f_goodbye => 2,
545             autopilot => 'b',
546       }]
547    }])
548   },
549   [
550     [ 'BEGIN' ],
551     [ 'INSERT INTO twokeys ( artist, cd)
552         VALUES ( ?, ? )',
553       '__BULK_INSERT__'
554     ],
555     [ 'INSERT INTO fourkeys_to_twokeys ( autopilot, f_bar, f_foo, f_goodbye, f_hello, t_artist, t_cd)
556         VALUES (
557           ?, ?, ?, ?, ?,
558           ( SELECT me.artist FROM twokeys me WHERE artist = ? AND cd = ? ),
559           ( SELECT me.cd FROM twokeys me WHERE artist = ? AND cd = ? )
560         )
561       ',
562       '__BULK_INSERT__'
563     ],
564     [ 'COMMIT' ],
565   ],
566   'multicol-PK has_many populate expected trace'
567 );
568
569 lives_ok ( sub {
570   $schema->populate('CD', [
571     {cdid => 10001, artist => $artist->id, title => 'Pretty Much Empty', year => 2011, tracks => []},
572   ])
573 }, 'empty has_many relationship accepted by populate');
574
575 done_testing;