Commit | Line | Data |
70350518 |
1 | use strict; |
68de9438 |
2 | use warnings; |
70350518 |
3 | |
4 | use Test::More; |
74de7c2c |
5 | use Test::Exception; |
722274d0 |
6 | use Test::Warn; |
da6a5860 |
7 | |
8 | use DBI::Const::GetInfoType; |
9 | use Scalar::Util qw/weaken/; |
199fbc45 |
10 | use DBIx::Class::Optional::Dependencies (); |
da6a5860 |
11 | |
70350518 |
12 | use lib qw(t/lib); |
13 | use DBICTest; |
0567538f |
14 | |
199fbc45 |
15 | plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mysql') |
16 | unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mysql'); |
17 | |
0567538f |
18 | my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}; |
19 | |
70350518 |
20 | plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test' |
0567538f |
21 | unless ($dsn && $user); |
22 | |
5f6bada6 |
23 | my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { quote_names => 1 }); |
0567538f |
24 | |
3ff5b740 |
25 | my $dbh = $schema->storage->dbh; |
0567538f |
26 | |
27 | $dbh->do("DROP TABLE IF EXISTS artist;"); |
28 | |
a0dd8679 |
29 | $dbh->do("CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10));"); |
0567538f |
30 | |
74de7c2c |
31 | $dbh->do("DROP TABLE IF EXISTS cd;"); |
32 | |
e0d56e26 |
33 | $dbh->do("CREATE TABLE cd (cdid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, artist INTEGER, title TEXT, year DATE, genreid INTEGER, single_track INTEGER);"); |
74de7c2c |
34 | |
35 | $dbh->do("DROP TABLE IF EXISTS producer;"); |
36 | |
37 | $dbh->do("CREATE TABLE producer (producerid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name TEXT);"); |
38 | |
39 | $dbh->do("DROP TABLE IF EXISTS cd_to_producer;"); |
40 | |
41 | $dbh->do("CREATE TABLE cd_to_producer (cd INTEGER,producer INTEGER);"); |
42 | |
bed3a173 |
43 | $dbh->do("DROP TABLE IF EXISTS owners;"); |
44 | |
45 | $dbh->do("CREATE TABLE owners (id INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(100) NOT NULL);"); |
46 | |
47 | $dbh->do("DROP TABLE IF EXISTS books;"); |
48 | |
49 | $dbh->do("CREATE TABLE books (id INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, source VARCHAR(100) NOT NULL, owner integer NOT NULL, title varchar(100) NOT NULL, price integer);"); |
50 | |
0567538f |
51 | #'dbi:mysql:host=localhost;database=dbic_test', 'dbic_test', ''); |
52 | |
8273e845 |
53 | # make sure sqlt_type overrides work (::Storage::DBI::mysql does this) |
adbf0c89 |
54 | { |
55 | my $schema = DBICTest::Schema->connect($dsn, $user, $pass); |
56 | |
57 | ok (!$schema->storage->_dbh, 'definitely not connected'); |
58 | is ($schema->storage->sqlt_type, 'MySQL', 'sqlt_type correct pre-connection'); |
59 | } |
60 | |
3ff5b740 |
61 | # This is in Core now, but it's here just to test that it doesn't break |
62 | $schema->class('Artist')->load_components('PK::Auto'); |
0567538f |
63 | |
64 | # test primary key handling |
3ff5b740 |
65 | my $new = $schema->resultset('Artist')->create({ name => 'foo' }); |
0567538f |
66 | ok($new->artistid, "Auto-PK worked"); |
67 | |
68 | # test LIMIT support |
69 | for (1..6) { |
3ff5b740 |
70 | $schema->resultset('Artist')->create({ name => 'Artist ' . $_ }); |
0567538f |
71 | } |
3ff5b740 |
72 | my $it = $schema->resultset('Artist')->search( {}, |
0567538f |
73 | { rows => 3, |
74 | offset => 2, |
75 | order_by => 'artistid' } |
76 | ); |
fb4b58e8 |
77 | is( $it->count, 3, "LIMIT count ok" ); # ask for 3 rows out of 7 artists |
0567538f |
78 | is( $it->next->name, "Artist 2", "iterator->next ok" ); |
79 | $it->next; |
80 | $it->next; |
81 | is( $it->next, undef, "next past end of resultset ok" ); |
82 | |
e5372da4 |
83 | # Limit with select-lock |
84 | lives_ok { |
85 | $schema->txn_do (sub { |
86 | isa_ok ( |
87 | $schema->resultset('Artist')->find({artistid => 1}, {for => 'update', rows => 1}), |
88 | 'DBICTest::Schema::Artist', |
89 | ); |
90 | }); |
91 | } 'Limited FOR UPDATE select works'; |
92 | |
4e0a89e4 |
93 | # shared-lock |
94 | lives_ok { |
95 | $schema->txn_do (sub { |
96 | isa_ok ( |
97 | $schema->resultset('Artist')->find({artistid => 1}, {for => 'shared'}), |
98 | 'DBICTest::Schema::Artist', |
99 | ); |
100 | }); |
101 | } 'LOCK IN SHARE MODE select works'; |
102 | |
f45dc928 |
103 | my ($int_type_name, @undef_default) = DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE |
104 | ? ('integer') |
105 | : ( 'INT', default_value => undef ) |
106 | ; |
107 | |
a953d8d9 |
108 | my $test_type_info = { |
109 | 'artistid' => { |
f45dc928 |
110 | 'data_type' => $int_type_name, |
103e3e03 |
111 | 'is_nullable' => 0, |
fc22fbac |
112 | 'size' => 11, |
f45dc928 |
113 | @undef_default, |
a953d8d9 |
114 | }, |
115 | 'name' => { |
103e3e03 |
116 | 'data_type' => 'VARCHAR', |
a953d8d9 |
117 | 'is_nullable' => 1, |
a0dd8679 |
118 | 'size' => 100, |
f45dc928 |
119 | @undef_default, |
103e3e03 |
120 | }, |
39da2a2b |
121 | 'rank' => { |
f45dc928 |
122 | 'data_type' => $int_type_name, |
39da2a2b |
123 | 'is_nullable' => 0, |
124 | 'size' => 11, |
f45dc928 |
125 | DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE ? () : ( 'default_value' => '13' ), |
39da2a2b |
126 | }, |
103e3e03 |
127 | 'charfield' => { |
637219ab |
128 | 'data_type' => 'CHAR', |
103e3e03 |
129 | 'is_nullable' => 1, |
fc22fbac |
130 | 'size' => 10, |
f45dc928 |
131 | @undef_default, |
103e3e03 |
132 | }, |
a953d8d9 |
133 | }; |
134 | |
bed3a173 |
135 | $schema->populate ('Owners', [ |
136 | [qw/id name /], |
137 | [qw/1 wiggle/], |
138 | [qw/2 woggle/], |
139 | [qw/3 boggle/], |
140 | ]); |
141 | |
142 | $schema->populate ('BooksInLibrary', [ |
143 | [qw/source owner title /], |
13a2f031 |
144 | [qw/Library 1 secrets1/], |
145 | [qw/Eatery 1 secrets2/], |
146 | [qw/Library 2 secrets3/], |
bed3a173 |
147 | ]); |
148 | |
13a2f031 |
149 | # |
8273e845 |
150 | # try a distinct + prefetch on tables with identically named columns |
13a2f031 |
151 | # (mysql doesn't seem to like subqueries with equally named columns) |
152 | # |
bed3a173 |
153 | |
d758ec36 |
154 | { |
13a2f031 |
155 | # try a ->has_many direction (due to a 'multi' accessor the select/group_by group is collapsed) |
156 | my $owners = $schema->resultset ('Owners')->search ( |
157 | { 'books.id' => { '!=', undef }}, |
158 | { prefetch => 'books', distinct => 1 } |
159 | ); |
160 | my $owners2 = $schema->resultset ('Owners')->search ({ id => { -in => $owners->get_column ('me.id')->as_query }}); |
161 | for ($owners, $owners2) { |
b5963465 |
162 | is ($_->all, 2, 'Prefetched grouped search returns correct number of rows'); |
163 | is ($_->count, 2, 'Prefetched grouped search returns correct count'); |
13a2f031 |
164 | } |
165 | |
d758ec36 |
166 | # try a ->belongs_to direction (no select collapse) |
b5963465 |
167 | my $books = $schema->resultset ('BooksInLibrary')->search ( |
168 | { 'owner.name' => 'wiggle' }, |
169 | { prefetch => 'owner', distinct => 1 } |
170 | ); |
171 | my $books2 = $schema->resultset ('BooksInLibrary')->search ({ id => { -in => $books->get_column ('me.id')->as_query }}); |
172 | for ($books, $books2) { |
173 | is ($_->all, 1, 'Prefetched grouped search returns correct number of rows'); |
174 | is ($_->count, 1, 'Prefetched grouped search returns correct count'); |
13a2f031 |
175 | } |
176 | } |
bed3a173 |
177 | |
5db49b9a |
178 | SKIP: { |
af1f4f84 |
179 | my $norm_version = $schema->storage->_server_info->{normalized_dbms_version} |
180 | or skip "Cannot determine MySQL server version", 1; |
a953d8d9 |
181 | |
af1f4f84 |
182 | if ($norm_version < 5.000003_01) { |
5db49b9a |
183 | $test_type_info->{charfield}->{data_type} = 'VARCHAR'; |
184 | } |
a953d8d9 |
185 | |
f45dc928 |
186 | if (DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE) { |
187 | $_->{data_type} = lc $_->{data_type} for values %$test_type_info; |
188 | } |
189 | |
3ff5b740 |
190 | my $type_info = $schema->storage->columns_info_for('artist'); |
5db49b9a |
191 | is_deeply($type_info, $test_type_info, 'columns_info_for - column data types'); |
192 | } |
a953d8d9 |
193 | |
6a999241 |
194 | my $cd = $schema->resultset ('CD')->create ({}); |
195 | my $producer = $schema->resultset ('Producer')->create ({}); |
196 | lives_ok { $cd->set_producers ([ $producer ]) } 'set_relationship doesnt die'; |
197 | |
aa82ce29 |
198 | { |
199 | my $artist = $schema->resultset('Artist')->next; |
200 | my $cd = $schema->resultset('CD')->next; |
201 | $cd->set_from_related ('artist', $artist); |
202 | $cd->update; |
203 | |
204 | my $rs = $schema->resultset('CD')->search ({}, { prefetch => 'artist' }); |
205 | |
206 | lives_ok sub { |
207 | my $cd = $rs->next; |
208 | is ($cd->artist->name, $artist->name, 'Prefetched artist'); |
209 | }, 'join does not throw (mysql 3 test)'; |
aa82ce29 |
210 | } |
6a999241 |
211 | |
55cfbb70 |
212 | ## Can we properly deal with the null search problem? |
a7e65bb5 |
213 | ## |
214 | ## Only way is to do a SET SQL_AUTO_IS_NULL = 0; on connect |
215 | ## But I'm not sure if we should do this or not (Ash, 2008/06/03) |
0fde80d9 |
216 | # |
217 | # There is now a built-in function to do this, test that everything works |
218 | # with it (ribasushi, 2009/07/03) |
55cfbb70 |
219 | |
220 | NULLINSEARCH: { |
97a0a148 |
221 | my $ansi_schema = DBICTest::Schema->connect ($dsn, $user, $pass, { on_connect_call => 'set_strict_mode' }); |
8de9298c |
222 | |
223 | $ansi_schema->resultset('Artist')->create ({ name => 'last created artist' }); |
6a999241 |
224 | |
225 | ok my $artist1_rs = $ansi_schema->resultset('Artist')->search({artistid=>6666}) |
226 | => 'Created an artist resultset of 6666'; |
227 | |
55cfbb70 |
228 | is $artist1_rs->count, 0 |
6a999241 |
229 | => 'Got no returned rows'; |
374dd926 |
230 | |
6a999241 |
231 | ok my $artist2_rs = $ansi_schema->resultset('Artist')->search({artistid=>undef}) |
232 | => 'Created an artist resultset of undef'; |
74de7c2c |
233 | |
6a999241 |
234 | is $artist2_rs->count, 0 |
235 | => 'got no rows'; |
74de7c2c |
236 | |
6a999241 |
237 | my $artist = $artist2_rs->single; |
55cfbb70 |
238 | |
5083f7de |
239 | is $artist => undef, |
6a999241 |
240 | => 'Nothing Found!'; |
74de7c2c |
241 | } |
aa82ce29 |
242 | |
0ce4ab92 |
243 | # check for proper grouped counts |
244 | { |
9f775126 |
245 | my $ansi_schema = DBICTest::Schema->connect ($dsn, $user, $pass, { |
246 | on_connect_call => 'set_strict_mode', |
247 | quote_char => '`', |
9f775126 |
248 | }); |
0ce4ab92 |
249 | my $rs = $ansi_schema->resultset('CD'); |
250 | |
251 | my $years; |
252 | $years->{$_->year|| scalar keys %$years}++ for $rs->all; # NULL != NULL, thus the keys eval |
253 | |
254 | lives_ok ( sub { |
255 | is ( |
256 | $rs->search ({}, { group_by => 'year'})->count, |
257 | scalar keys %$years, |
258 | 'grouped count correct', |
259 | ); |
260 | }, 'Grouped count does not throw'); |
9f775126 |
261 | |
262 | lives_ok( sub { |
263 | $ansi_schema->resultset('Owners')->search({}, { |
264 | join => 'books', group_by => [ 'me.id', 'books.id' ] |
265 | })->count(); |
266 | }, 'count on grouped columns with the same name does not throw'); |
0ce4ab92 |
267 | } |
268 | |
45150bc4 |
269 | # a more contrived^Wcomplicated self-referential double-subquery test |
270 | { |
271 | my $rs = $schema->resultset('Artist')->search({ name => { -like => 'baby_%' } }); |
272 | |
273 | $rs->populate([map { [$_] } ('name', map { "baby_$_" } (1..10) ) ]); |
274 | |
275 | my ($count_sql, @count_bind) = @${$rs->count_rs->as_query}; |
276 | |
277 | my $complex_rs = $schema->resultset('Artist')->search( |
278 | { artistid => { |
279 | -in => $rs->get_column('artistid') |
280 | ->as_query |
281 | } }, |
282 | ); |
283 | |
284 | $complex_rs->update({ name => \[ "CONCAT( `name`, '_bell_out_of_', $count_sql )", @count_bind ] }); |
285 | |
286 | for (1..10) { |
287 | is ( |
288 | $schema->resultset('Artist')->search({ name => "baby_${_}_bell_out_of_10" })->count, |
289 | 1, |
290 | "Correctly updated babybell $_", |
291 | ); |
292 | } |
293 | |
f4fdfd69 |
294 | is ($rs->count, 10, '10 artists present'); |
45150bc4 |
295 | |
49eeb48d |
296 | $schema->is_executed_querycount( sub { |
297 | $complex_rs->delete; |
298 | }, 1, 'One delete query fired' ); |
f4fdfd69 |
299 | is ($rs->count, 0, '10 Artists correctly deleted'); |
300 | |
301 | $rs->create({ |
302 | name => 'baby_with_cd', |
303 | cds => [ { title => 'babeeeeee', year => 2013 } ], |
304 | }); |
305 | is ($rs->count, 1, 'Artist with cd created'); |
306 | |
f4fdfd69 |
307 | |
49eeb48d |
308 | $schema->is_executed_querycount( sub { |
309 | $schema->resultset('CD')->search_related('artist', |
310 | { 'artist.name' => { -like => 'baby_with_%' } } |
311 | )->delete; |
312 | }, 1, 'And one more delete query fired'); |
313 | is ($rs->count, 0, 'Artist with cd deleted'); |
45150bc4 |
314 | } |
315 | |
e0d56e26 |
316 | ZEROINSEARCH: { |
317 | my $cds_per_year = { |
318 | 2001 => 2, |
319 | 2002 => 1, |
320 | 2005 => 3, |
321 | }; |
322 | |
323 | my $rs = $schema->resultset ('CD'); |
324 | $rs->delete; |
325 | for my $y (keys %$cds_per_year) { |
326 | for my $c (1 .. $cds_per_year->{$y} ) { |
327 | $rs->create ({ title => "CD $y-$c", artist => 1, year => "$y-01-01" }); |
328 | } |
329 | } |
330 | |
331 | is ($rs->count, 6, 'CDs created successfully'); |
332 | |
333 | $rs = $rs->search ({}, { |
ca458871 |
334 | select => [ \ 'YEAR(year)' ], as => ['y'], distinct => 1, |
e0d56e26 |
335 | }); |
336 | |
722274d0 |
337 | my $y_rs = $rs->get_column ('y'); |
338 | |
339 | warnings_exist { is_deeply ( |
340 | [ sort ($y_rs->all) ], |
e0d56e26 |
341 | [ sort keys %$cds_per_year ], |
342 | 'Years group successfully', |
722274d0 |
343 | ) } qr/ |
344 | \QUse of distinct => 1 while selecting anything other than a column \E |
345 | \Qdeclared on the primary ResultSource is deprecated\E |
346 | /x, 'deprecation warning'; |
347 | |
e0d56e26 |
348 | |
349 | $rs->create ({ artist => 1, year => '0-1-1', title => 'Jesus Rap' }); |
350 | |
351 | is_deeply ( |
722274d0 |
352 | [ sort $y_rs->all ], |
e0d56e26 |
353 | [ 0, sort keys %$cds_per_year ], |
354 | 'Zero-year groups successfully', |
355 | ); |
356 | |
8273e845 |
357 | # convoluted search taken verbatim from list |
e0d56e26 |
358 | my $restrict_rs = $rs->search({ -and => [ |
359 | year => { '!=', 0 }, |
360 | year => { '!=', undef } |
361 | ]}); |
362 | |
722274d0 |
363 | warnings_exist { is_deeply ( |
1b658919 |
364 | [ sort $restrict_rs->get_column('y')->all ], |
365 | [ sort $y_rs->all ], |
e0d56e26 |
366 | 'Zero year was correctly excluded from resultset', |
722274d0 |
367 | ) } qr/ |
368 | \QUse of distinct => 1 while selecting anything other than a column \E |
369 | \Qdeclared on the primary ResultSource is deprecated\E |
370 | /x, 'deprecation warning'; |
e0d56e26 |
371 | } |
10176e1f |
372 | |
f98120e4 |
373 | # make sure find hooks determine driver |
374 | { |
375 | my $schema = DBICTest::Schema->connect($dsn, $user, $pass); |
376 | $schema->resultset("Artist")->find(4); |
377 | isa_ok($schema->storage->sql_maker, 'DBIx::Class::SQLMaker::MySQL'); |
378 | } |
379 | |
380 | # make sure the mysql_auto_reconnect buggery is avoided |
381 | { |
382 | local $ENV{MOD_PERL} = 'boogiewoogie'; |
383 | my $schema = DBICTest::Schema->connect($dsn, $user, $pass); |
384 | ok (! $schema->storage->_get_dbh->{mysql_auto_reconnect}, 'mysql_auto_reconnect unset regardless of ENV' ); |
385 | |
da6a5860 |
386 | # Make sure hardcore forking action still works even if mysql_auto_reconnect |
387 | # is true (test inspired by ether) |
388 | |
389 | my $schema_autorecon = DBICTest::Schema->connect($dsn, $user, $pass, { mysql_auto_reconnect => 1 }); |
390 | my $orig_dbh = $schema_autorecon->storage->_get_dbh; |
391 | weaken $orig_dbh; |
392 | |
393 | ok ($orig_dbh, 'Got weak $dbh ref'); |
394 | ok ($orig_dbh->{mysql_auto_reconnect}, 'mysql_auto_reconnect is properly set if explicitly requested' ); |
395 | |
396 | my $rs = $schema_autorecon->resultset('Artist'); |
397 | |
7be5717e |
398 | my ($parent_in, $child_out); |
399 | pipe( $parent_in, $child_out ) or die "Pipe open failed: $!"; |
da6a5860 |
400 | my $pid = fork(); |
401 | if (! defined $pid ) { |
402 | die "fork() failed: $!" |
403 | } |
404 | elsif ($pid) { |
7be5717e |
405 | close $child_out; |
406 | |
da6a5860 |
407 | # sanity check |
408 | $schema_autorecon->storage->dbh_do(sub { |
409 | is ($_[1], $orig_dbh, 'Storage holds correct $dbh in parent'); |
410 | }); |
411 | |
412 | # kill our $dbh |
413 | $schema_autorecon->storage->_dbh(undef); |
e0b2dc74 |
414 | |
4ca1fd6f |
415 | { |
e0b2dc74 |
416 | local $TODO = "Perl $] is known to leak like a sieve" |
0d8817bc |
417 | if DBIx::Class::_ENV_::PEEPEENESS; |
e0b2dc74 |
418 | |
419 | ok (! defined $orig_dbh, 'Parent $dbh handle is gone'); |
420 | } |
da6a5860 |
421 | } |
422 | else { |
7be5717e |
423 | close $parent_in; |
da6a5860 |
424 | |
425 | #simulate a subtest to not confuse the parent TAP emission |
7be5717e |
426 | my $tb = Test::More->builder; |
427 | $tb->reset; |
428 | for (qw/output failure_output todo_output/) { |
429 | close $tb->$_; |
430 | open ($tb->$_, '>&', $child_out); |
431 | } |
432 | |
433 | # wait for parent to kill its $dbh |
434 | sleep 1; |
da6a5860 |
435 | |
da6a5860 |
436 | # try to do something dbic-esque |
437 | $rs->create({ name => "Hardcore Forker $$" }); |
438 | |
4ca1fd6f |
439 | { |
e0b2dc74 |
440 | local $TODO = "Perl $] is known to leak like a sieve" |
0d8817bc |
441 | if DBIx::Class::_ENV_::PEEPEENESS; |
e0b2dc74 |
442 | |
443 | ok (! defined $orig_dbh, 'DBIC operation triggered reconnect - old $dbh is gone'); |
444 | } |
da6a5860 |
445 | |
7be5717e |
446 | done_testing; |
da6a5860 |
447 | exit 0; |
448 | } |
449 | |
7be5717e |
450 | while (my $ln = <$parent_in>) { |
451 | print " $ln"; |
452 | } |
da6a5860 |
453 | wait; |
454 | ok(!$?, 'Child subtests passed'); |
455 | |
456 | ok ($rs->find({ name => "Hardcore Forker $pid" }), 'Expected row created'); |
f98120e4 |
457 | } |
10176e1f |
458 | |
aa82ce29 |
459 | done_testing; |