Rename internal rsrc method to be more descriptive, stop proxying it
[dbsrgits/DBIx-Class.git] / t / 100populate.t
1 use strict;
2 use warnings;
3
4 use Test::More;
5 use Test::Exception;
6 use Test::Warn;
7 use lib qw(t/lib);
8 use DBICTest;
9 use Path::Class::File ();
10 use Math::BigInt;
11 use List::Util qw/shuffle/;
12 use Storable qw/nfreeze dclone/;
13
14 my $schema = DBICTest->init_schema();
15
16 # The map below generates stuff like:
17 #   [ qw/artistid name/ ],
18 #   [ 4, "b" ],
19 #   [ 5, "c" ],
20 #   ...
21 #   [ 9999, "ntm" ],
22 #   [ 10000, "ntn" ],
23
24 my $start_id = 'populateXaaaaaa';
25 my $rows = 10_000;
26 my $offset = 3;
27
28 $schema->populate('Artist', [ [ qw/artistid name/ ], map { [ ($_ + $offset) => $start_id++ ] } shuffle ( 1 .. $rows ) ] );
29 is (
30     $schema->resultset ('Artist')->search ({ name => { -like => 'populateX%' } })->count,
31     $rows,
32     'populate created correct number of rows with massive AoA bulk insert',
33 );
34
35 my $artist = $schema->resultset ('Artist')
36               ->search ({ 'cds.title' => { '!=', undef } }, { join => 'cds' })
37                 ->first;
38 my $ex_title = $artist->cds->first->title;
39
40 throws_ok ( sub {
41   my $i = 600;
42   $schema->populate('CD', [
43     map {
44       {
45         artist => $artist->id,
46         title => $_,
47         year => 2009,
48       }
49     } ('Huey', 'Dewey', $ex_title, 'Louie')
50   ])
51 }, qr/\Qexecute_for_fetch() aborted with '\E.+ at populate slice.+$ex_title/ms, 'Readable exception thrown for failed populate');
52
53 ## make sure populate honors fields/orders in list context
54 ## schema order
55 my @links = $schema->populate('Link', [
56 [ qw/id url title/ ],
57 [ qw/2 burl btitle/ ]
58 ]);
59 is(scalar @links, 1);
60
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');
65
66 ## non-schema order
67 @links = $schema->populate('Link', [
68 [ qw/id title url/ ],
69 [ qw/3 ctitle curl/ ]
70 ]);
71 is(scalar @links, 1);
72
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');
77
78 ## not all physical columns
79 @links = $schema->populate('Link', [
80 [ qw/id title/ ],
81 [ qw/4 dtitle/ ]
82 ]);
83 is(scalar @links, 1);
84
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');
89
90
91 ## make sure populate -> insert_bulk honors fields/orders in void context
92 ## schema order
93 $schema->populate('Link', [
94 [ qw/id url title/ ],
95 [ qw/5 eurl etitle/ ]
96 ]);
97 my $link5 = $schema->resultset('Link')->find(5);
98 is($link5->id, 5, 'Link 5 id');
99 is($link5->url, 'eurl', 'Link 5 url');
100 is($link5->title, 'etitle', 'Link 5 title');
101
102 ## non-schema order
103 $schema->populate('Link', [
104 [ qw/id title url/ ],
105 [ qw/6 ftitle furl/ ]
106 ]);
107 my $link6 = $schema->resultset('Link')->find(6);
108 is($link6->id, 6, 'Link 6 id');
109 is($link6->url, 'furl', 'Link 6 url');
110 is($link6->title, 'ftitle', 'Link 6 title');
111
112 ## not all physical columns
113 $schema->populate('Link', [
114 [ qw/id title/ ],
115 [ qw/7 gtitle/ ]
116 ]);
117 my $link7 = $schema->resultset('Link')->find(7);
118 is($link7->id, 7, 'Link 7 id');
119 is($link7->url, undef, 'Link 7 url');
120 is($link7->title, 'gtitle', 'Link 7 title');
121
122 # populate with literals
123 {
124   my $rs = $schema->resultset('Link');
125   $rs->delete;
126
127   # test insert_bulk with all literal sql (no binds)
128
129   $rs->populate([
130     (+{
131         url => \"'cpan.org'",
132         title => \"'The ''best of'' cpan'",
133     }) x 5
134   ]);
135
136   is((grep {
137     $_->url eq 'cpan.org' &&
138     $_->title eq "The 'best of' cpan",
139   } $rs->all), 5, 'populate with all literal SQL');
140
141   $rs->delete;
142
143   # test mixed binds with literal sql
144
145   $rs->populate([
146     (+{
147         url => \"'cpan.org'",
148         title => "The 'best of' cpan",
149     }) x 5
150   ]);
151
152   is((grep {
153     $_->url eq 'cpan.org' &&
154     $_->title eq "The 'best of' cpan",
155   } $rs->all), 5, 'populate with all literal SQL');
156
157   $rs->delete;
158 }
159
160 # populate with literal+bind
161 {
162   my $rs = $schema->resultset('Link');
163   $rs->delete;
164
165   # test insert_bulk with all literal/bind sql
166   $rs->populate([
167     (+{
168         url => \['?', [ {} => 'cpan.org' ] ],
169         title => \['?', [ {} => "The 'best of' cpan" ] ],
170     }) x 5
171   ]);
172
173   is((grep {
174     $_->url eq 'cpan.org' &&
175     $_->title eq "The 'best of' cpan",
176   } $rs->all), 5, 'populate with all literal/bind');
177
178   $rs->delete;
179
180   # test insert_bulk with mix literal and literal/bind
181   $rs->populate([
182     (+{
183         url => \"'cpan.org'",
184         title => \['?', [ {} => "The 'best of' cpan" ] ],
185     }) x 5
186   ]);
187
188   is((grep {
189     $_->url eq 'cpan.org' &&
190     $_->title eq "The 'best of' cpan",
191   } $rs->all), 5, 'populate with all literal/bind SQL');
192
193   $rs->delete;
194
195   # test mixed binds with literal sql/bind
196
197   $rs->populate([ map { +{
198     url => \[ '? || ?', [ {} => 'cpan.org_' ], [ undef, $_ ] ],
199     title => "The 'best of' cpan",
200   } } (1 .. 5) ]);
201
202   for (1 .. 5) {
203     ok($rs->find({ url => "cpan.org_$_" }), "Row $_ correctly created with dynamic literal/bind populate" );
204   }
205
206   $rs->delete;
207 }
208
209 my $rs = $schema->resultset('Artist');
210 $rs->delete;
211 throws_ok {
212     $rs->populate([
213         {
214             artistid => 1,
215             name => 'foo1',
216         },
217         {
218             artistid => 'foo', # this dies
219             name => 'foo2',
220         },
221         {
222             artistid => 3,
223             name => 'foo3',
224         },
225     ]);
226 } qr/\Qexecute_for_fetch() aborted with 'datatype mismatch\E\b/, 'bad slice';
227
228 is($rs->count, 0, 'populate is atomic');
229
230 # Trying to use a column marked as a bind in the first slice with literal sql in
231 # a later slice should throw.
232
233 throws_ok {
234   $rs->populate([
235     {
236       artistid => 1,
237       name => \"'foo'",
238     },
239     {
240       artistid => \2,
241       name => \"'foo'",
242     }
243   ]);
244 } qr/Literal SQL found where a plain bind value is expected/, 'literal sql where bind expected throws';
245
246 # ... and vice-versa.
247
248 throws_ok {
249   $rs->populate([
250     {
251       artistid => \1,
252       name => \"'foo'",
253     },
254     {
255       artistid => 2,
256       name => \"'foo'",
257     }
258   ]);
259 } qr/\QIncorrect value (expecting SCALAR-ref/, 'bind where literal sql expected throws';
260
261 throws_ok {
262   $rs->populate([
263     {
264       artistid => 1,
265       name => \"'foo'",
266     },
267     {
268       artistid => 2,
269       name => \"'bar'",
270     }
271   ]);
272 } qr/Inconsistent literal SQL value/, 'literal sql must be the same in all slices';
273
274 throws_ok {
275   $rs->populate([
276     {
277       artistid => 1,
278       name => \['?', [ {} => 'foo' ] ],
279     },
280     {
281       artistid => 2,
282       name => \"'bar'",
283     }
284   ]);
285 } qr/\QIncorrect value (expecting ARRAYREF-ref/, 'literal where literal+bind expected throws';
286
287 throws_ok {
288   $rs->populate([
289     {
290       artistid => 1,
291       name => \['?', [ { sqlt_datatype => 'foooo' } => 'foo' ] ],
292     },
293     {
294       artistid => 2,
295       name => \['?', [ {} => 'foo' ] ],
296     }
297   ]);
298 } qr/\QDiffering bind attributes on literal\/bind values not supported for column 'name'/, 'literal+bind with differing attrs throws';
299
300 lives_ok {
301   $rs->populate([
302     {
303       artistid => 1,
304       name => \['?', [ undef, 'foo' ] ],
305     },
306     {
307       artistid => 2,
308       name => \['?', [ {} => 'bar' ] ],
309     }
310   ]);
311 } 'literal+bind with semantically identical attrs works after normalization';
312
313 # test all kinds of population with stringified objects
314 warnings_like {
315   local $ENV{DBIC_RT79576_NOWARN};
316
317   my $rs = $schema->resultset('Artist')->search({}, { columns => [qw(name rank)], order_by => 'artistid' });
318
319   # the stringification has nothing to do with the artist name
320   # this is solely for testing consistency
321   my $fn = Path::Class::File->new ('somedir/somefilename.tmp');
322   my $fn2 = Path::Class::File->new ('somedir/someotherfilename.tmp');
323   my $rank = Math::BigInt->new(42);
324
325   my $args = {
326     'stringifying objects after regular values' => [ map
327       { { name => $_, rank => $rank } }
328       (
329         'supplied before stringifying objects',
330         'supplied before stringifying objects 2',
331         $fn,
332         $fn2,
333       )
334     ],
335     'stringifying objects before regular values' => [ map
336       { { name => $_, rank => $rank } }
337       (
338         $fn,
339         $fn2,
340         'supplied after stringifying objects',
341         'supplied after stringifying objects 2',
342       )
343     ],
344     'stringifying objects between regular values' => [ map
345       { { name => $_, rank => $rank } }
346       (
347         'supplied before stringifying objects',
348         $fn,
349         $fn2,
350         'supplied after stringifying objects',
351       )
352     ],
353     'stringifying objects around regular values' => [ map
354       { { name => $_, rank => $rank } }
355       (
356         $fn,
357         'supplied between stringifying objects',
358         $fn2,
359       )
360     ],
361   };
362
363   local $Storable::canonical = 1;
364   my $preimage = nfreeze([$fn, $fn2, $rank, $args]);
365
366   for my $tst (keys %$args) {
367
368     # test void ctx
369     $rs->delete;
370     $rs->populate($args->{$tst});
371     is_deeply(
372       $rs->all_hri,
373       $args->{$tst},
374       "Populate() $tst in void context"
375     );
376
377     # test non-void ctx
378     $rs->delete;
379     my $dummy = $rs->populate($args->{$tst});
380     is_deeply(
381       $rs->all_hri,
382       $args->{$tst},
383       "Populate() $tst in non-void context"
384     );
385
386     # test create() as we have everything set up already
387     $rs->delete;
388     $rs->create($_) for @{$args->{$tst}};
389
390     is_deeply(
391       $rs->all_hri,
392       $args->{$tst},
393       "Create() $tst"
394     );
395   }
396
397   ok (
398     ($preimage eq nfreeze( [$fn, $fn2, $rank, $args] )),
399     'Arguments fed to populate()/create() unchanged'
400   );
401
402   $rs->delete;
403 } [
404   # warning to be removed around Apr 1st 2015
405   # smokers start failing a month before that
406   (
407     ( DBICTest::RunMode->is_author and ( time() > 1427846400 ) )
408       or
409     ( DBICTest::RunMode->is_smoker and ( time() > 1425168000 ) )
410   )
411     ? ()
412     # one unique for populate() and create() each
413     : (qr/\QPOSSIBLE *PAST* DATA CORRUPTION detected \E.+\QTrigger condition encountered at @{[ __FILE__ ]} line\E \d/) x 2
414 ], 'Data integrity warnings as planned';
415
416 lives_ok {
417    $schema->resultset('TwoKeys')->populate([{
418       artist => 1,
419       cd     => 5,
420       fourkeys_to_twokeys => [{
421             f_foo => 1,
422             f_bar => 1,
423             f_hello => 1,
424             f_goodbye => 1,
425             autopilot => 'a',
426       },{
427             f_foo => 2,
428             f_bar => 2,
429             f_hello => 2,
430             f_goodbye => 2,
431             autopilot => 'b',
432       }]
433    }])
434 } 'multicol-PK has_many populate works';
435
436 lives_ok ( sub {
437   $schema->populate('CD', [
438     {cdid => 10001, artist => $artist->id, title => 'Pretty Much Empty', year => 2011, tracks => []},
439   ])
440 }, 'empty has_many relationship accepted by populate');
441
442 done_testing;