Commit | Line | Data |
c1cac633 |
1 | use strict; |
b9a2c3a5 |
2 | use warnings; |
c1cac633 |
3 | |
4 | use Test::More; |
893403c8 |
5 | use Test::Exception; |
c1cac633 |
6 | use lib qw(t/lib); |
7 | use DBICTest; |
b2d16f1f |
8 | use DBIC::SqlMakerTest; |
c1cac633 |
9 | |
10 | my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/}; |
11 | |
12 | plan skip_all => 'Set $ENV{DBICTEST_MSSQL_ODBC_DSN}, _USER and _PASS to run this test' |
13 | unless ($dsn && $user); |
14 | |
ca791b95 |
15 | DBICTest::Schema->load_classes('ArtistGUID'); |
42e5b103 |
16 | my $schema = DBICTest::Schema->connect($dsn, $user, $pass); |
c1cac633 |
17 | |
8c0104fe |
18 | { |
19 | no warnings 'redefine'; |
20 | my $connect_count = 0; |
21 | my $orig_connect = \&DBI::connect; |
22 | local *DBI::connect = sub { $connect_count++; goto &$orig_connect }; |
23 | |
24 | $schema->storage->ensure_connected; |
25 | |
26 | is( $connect_count, 1, 'only one connection made'); |
27 | } |
9b3e916d |
28 | |
c1cac633 |
29 | isa_ok( $schema->storage, 'DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server' ); |
30 | |
cf89555e |
31 | { |
32 | my $schema2 = $schema->connect ($schema->storage->connect_info); |
33 | ok (! $schema2->storage->connected, 'a re-connected cloned schema starts unconnected'); |
34 | } |
35 | |
ecdf1ac8 |
36 | $schema->storage->_dbh->disconnect; |
37 | |
38 | lives_ok { |
39 | $schema->storage->dbh_do(sub { $_[1]->do('select 1') }) |
40 | } '_ping works'; |
41 | |
c5f77f6c |
42 | $schema->storage->dbh_do (sub { |
43 | my ($storage, $dbh) = @_; |
44 | eval { $dbh->do("DROP TABLE artist") }; |
45 | $dbh->do(<<'SQL'); |
c1cac633 |
46 | CREATE TABLE artist ( |
47 | artistid INT IDENTITY NOT NULL, |
a0dd8679 |
48 | name VARCHAR(100), |
39da2a2b |
49 | rank INT NOT NULL DEFAULT '13', |
2eebd801 |
50 | charfield CHAR(10) NULL, |
c1cac633 |
51 | primary key(artistid) |
52 | ) |
c5f77f6c |
53 | SQL |
c5f77f6c |
54 | }); |
55 | |
c1cac633 |
56 | my %seen_id; |
57 | |
7b1b2582 |
58 | my @opts = ( |
59 | { on_connect_call => 'use_dynamic_cursors' }, |
60 | {}, |
61 | ); |
7b1b2582 |
62 | # test Auto-PK with different options |
63 | for my $opts (@opts) { |
41dd5d30 |
64 | SKIP: { |
65 | $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts); |
7b1b2582 |
66 | |
41dd5d30 |
67 | eval { |
68 | $schema->storage->ensure_connected |
69 | }; |
70 | if ($@ =~ /dynamic cursors/) { |
71 | skip |
72 | 'Dynamic Cursors not functional, tds_version 8.0 or greater required if using'. |
73 | ' FreeTDS', 1; |
74 | } |
7b1b2582 |
75 | |
41dd5d30 |
76 | $schema->resultset('Artist')->search({ name => 'foo' })->delete; |
77 | |
a54bd479 |
78 | my $new = $schema->resultset('Artist')->create({ name => 'foo' }); |
41dd5d30 |
79 | |
80 | ok($new->artistid > 0, "Auto-PK worked"); |
81 | } |
7b1b2582 |
82 | } |
c1cac633 |
83 | |
ca791b95 |
84 | |
ca791b95 |
85 | |
a54bd479 |
86 | # Test populate |
f6b185e1 |
87 | |
a54bd479 |
88 | { |
89 | $schema->storage->dbh_do (sub { |
b9a2c3a5 |
90 | my ($storage, $dbh) = @_; |
02495deb |
91 | eval { $dbh->do("DROP TABLE owners") }; |
92 | eval { $dbh->do("DROP TABLE books") }; |
b9a2c3a5 |
93 | $dbh->do(<<'SQL'); |
02495deb |
94 | CREATE TABLE books ( |
b9a2c3a5 |
95 | id INT IDENTITY (1, 1) NOT NULL, |
96 | source VARCHAR(100), |
97 | owner INT, |
98 | title VARCHAR(10), |
99 | price INT NULL |
100 | ) |
101 | |
02495deb |
102 | CREATE TABLE owners ( |
b9a2c3a5 |
103 | id INT IDENTITY (1, 1) NOT NULL, |
42e5b103 |
104 | name VARCHAR(100), |
b9a2c3a5 |
105 | ) |
b9a2c3a5 |
106 | SQL |
107 | |
a54bd479 |
108 | }); |
fb7cd45f |
109 | |
a54bd479 |
110 | lives_ok ( sub { |
111 | # start a new connection, make sure rebless works |
112 | my $schema = DBICTest::Schema->connect($dsn, $user, $pass); |
113 | $schema->populate ('Owners', [ |
114 | [qw/id name /], |
115 | [qw/1 wiggle/], |
116 | [qw/2 woggle/], |
117 | [qw/3 boggle/], |
118 | [qw/4 fRIOUX/], |
119 | [qw/5 fRUE/], |
120 | [qw/6 fREW/], |
121 | [qw/7 fROOH/], |
122 | [qw/8 fISMBoC/], |
123 | [qw/9 station/], |
124 | [qw/10 mirror/], |
125 | [qw/11 dimly/], |
126 | [qw/12 face_to_face/], |
127 | [qw/13 icarus/], |
128 | [qw/14 dream/], |
129 | [qw/15 dyrstyggyr/], |
130 | ]); |
131 | }, 'populate with PKs supplied ok' ); |
132 | |
133 | |
134 | lives_ok (sub { |
135 | # start a new connection, make sure rebless works |
136 | # test an insert with a supplied identity, followed by one without |
137 | my $schema = DBICTest::Schema->connect($dsn, $user, $pass); |
138 | for (2, 1) { |
139 | my $id = $_ * 20 ; |
140 | $schema->resultset ('Owners')->create ({ id => $id, name => "troglodoogle $id" }); |
141 | $schema->resultset ('Owners')->create ({ name => "troglodoogle " . ($id + 1) }); |
142 | } |
143 | }, 'create with/without PKs ok' ); |
144 | |
145 | is ($schema->resultset ('Owners')->count, 19, 'owner rows really in db' ); |
146 | |
147 | lives_ok ( sub { |
148 | # start a new connection, make sure rebless works |
149 | my $schema = DBICTest::Schema->connect($dsn, $user, $pass); |
150 | $schema->populate ('BooksInLibrary', [ |
151 | [qw/source owner title /], |
152 | [qw/Library 1 secrets0/], |
153 | [qw/Library 1 secrets1/], |
154 | [qw/Eatery 1 secrets2/], |
155 | [qw/Library 2 secrets3/], |
156 | [qw/Library 3 secrets4/], |
157 | [qw/Eatery 3 secrets5/], |
158 | [qw/Library 4 secrets6/], |
159 | [qw/Library 5 secrets7/], |
160 | [qw/Eatery 5 secrets8/], |
161 | [qw/Library 6 secrets9/], |
162 | [qw/Library 7 secrets10/], |
163 | [qw/Eatery 7 secrets11/], |
164 | [qw/Library 8 secrets12/], |
165 | ]); |
166 | }, 'populate without PKs supplied ok' ); |
98c55e0b |
167 | } |
fb7cd45f |
168 | |
a54bd479 |
169 | # test simple, complex LIMIT and limited prefetch support, with both dialects and quote combinations (if possible) |
170 | for my $dialect ( |
171 | 'Top', |
172 | ($schema->storage->_server_info->{normalized_dbms_version} || 0 ) >= 9 |
173 | ? ('RowNumberOver') |
174 | : () |
175 | , |
176 | ) { |
177 | for my $quoted (0, 1) { |
178 | |
179 | $schema = DBICTest::Schema->connect($dsn, $user, $pass, { |
180 | limit_dialect => $dialect, |
181 | $quoted |
182 | ? ( quote_char => [ qw/ [ ] / ], name_sep => '.' ) |
183 | : () |
184 | , |
185 | }); |
186 | |
187 | my $test_type = "Dialect:$dialect Quoted:$quoted"; |
188 | |
189 | # basic limit support |
190 | TODO: { |
191 | my $art_rs = $schema->resultset ('Artist'); |
192 | $art_rs->delete; |
193 | $art_rs->create({ name => 'Artist ' . $_ }) for (1..6); |
194 | |
195 | my $it = $schema->resultset('Artist')->search( {}, { |
196 | rows => 4, |
197 | offset => 3, |
198 | order_by => 'artistid', |
199 | }); |
200 | |
201 | is( $it->count, 3, "$test_type: LIMIT count ok" ); |
202 | |
203 | local $TODO = "Top-limit does not work when your limit ends up past the resultset" |
204 | if $dialect eq 'Top'; |
205 | |
206 | is( $it->next->name, 'Artist 4', "$test_type: iterator->next ok" ); |
207 | $it->next; |
208 | is( $it->next->name, 'Artist 6', "$test_type: iterator->next ok" ); |
209 | is( $it->next, undef, "$test_type: next past end of resultset ok" ); |
210 | } |
fb7cd45f |
211 | |
a54bd479 |
212 | # plain ordered subqueries throw |
213 | throws_ok (sub { |
214 | $schema->resultset('Owners')->search ({}, { order_by => 'name' })->as_query |
215 | }, qr/ordered subselect encountered/, "$test_type: Ordered Subselect detection throws ok"); |
f0bd60fc |
216 | |
a54bd479 |
217 | # make sure ordered subselects *somewhat* work |
218 | { |
219 | my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 }); |
220 | my $sealed_owners = $owners->as_subselect_rs; |
221 | |
222 | is_deeply ( |
223 | [ map { $_->name } ($sealed_owners->all) ], |
224 | [ map { $_->name } ($owners->all) ], |
225 | "$test_type: Sort preserved from within a subquery", |
226 | ); |
227 | } |
f0bd60fc |
228 | |
a54bd479 |
229 | { |
230 | my $book_owner_ids = $schema->resultset ('BooksInLibrary')->search ({}, { |
231 | rows => 6, |
232 | offset => 2, |
233 | join => 'owner', |
234 | distinct => 1, |
235 | order_by => 'owner.name', |
236 | unsafe_subselect_ok => 1 |
237 | })->get_column ('owner'); |
238 | |
239 | my @ids = $book_owner_ids->all; |
240 | |
241 | is (@ids, 6, 'Limit works'); |
242 | |
243 | my $book_owners = $schema->resultset ('Owners')->search ({ |
244 | id => { -in => $book_owner_ids->as_query } |
245 | }); |
246 | |
247 | TODO: { |
248 | local $TODO = "Correlated limited IN subqueries will probably never preserve order"; |
249 | |
250 | is_deeply ( |
251 | [ map { $_->id } ($book_owners->all) ], |
252 | [ $book_owner_ids->all ], |
253 | "$test_type: Sort is preserved across IN subqueries", |
254 | ); |
255 | } |
256 | } |
fb7cd45f |
257 | |
a54bd479 |
258 | # still even with lost order of IN, we should be getting correct |
259 | # sets |
6de07ea3 |
260 | { |
a54bd479 |
261 | my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 }); |
262 | my $corelated_owners = $owners->result_source->resultset->search ( |
263 | { |
264 | id => { -in => $owners->get_column('id')->as_query }, |
265 | }, |
266 | { |
267 | order_by => 'name' #reorder because of what is shown above |
268 | }, |
269 | ); |
270 | |
271 | is ( |
272 | join ("\x00", map { $_->name } ($corelated_owners->all) ), |
273 | join ("\x00", map { $_->name } ($owners->all) ), |
274 | "$test_type: With an outer order_by, everything still matches", |
275 | ); |
276 | } |
277 | |
278 | # make sure right-join-side single-prefetch ordering limit works |
6de07ea3 |
279 | { |
a54bd479 |
280 | my $rs = $schema->resultset ('BooksInLibrary')->search ( |
281 | { |
282 | 'owner.name' => { '!=', 'woggle' }, |
283 | }, |
284 | { |
285 | prefetch => 'owner', |
286 | order_by => 'owner.name', |
287 | } |
288 | ); |
289 | # this is the order in which they should come from the above query |
290 | my @owner_names = qw/boggle fISMBoC fREW fRIOUX fROOH fRUE wiggle wiggle/; |
291 | |
292 | is ($rs->all, 8, "$test_type: Correct amount of objects from right-sorted joined resultset"); |
293 | is_deeply ( |
294 | [map { $_->owner->name } ($rs->all) ], |
295 | \@owner_names, |
296 | "$test_type: Prefetched rows were properly ordered" |
297 | ); |
298 | |
299 | my $limited_rs = $rs->search ({}, {rows => 6, offset => 2, unsafe_subselect_ok => 1}); |
300 | is ($limited_rs->count, 6, "$test_type: Correct count of limited right-sorted joined resultset"); |
301 | is ($limited_rs->count_rs->next, 6, "$test_type: Correct count_rs of limited right-sorted joined resultset"); |
302 | |
303 | my $queries; |
25abda27 |
304 | my $orig_debug = $schema->storage->debug; |
a54bd479 |
305 | $schema->storage->debugcb(sub { $queries++; }); |
306 | $schema->storage->debug(1); |
307 | |
308 | is_deeply ( |
309 | [map { $_->owner->name } ($limited_rs->all) ], |
310 | [@owner_names[2 .. 7]], |
311 | "$test_type: Prefetch-limited rows were properly ordered" |
312 | ); |
313 | is ($queries, 1, "$test_type: Only one query with prefetch"); |
314 | |
315 | $schema->storage->debugcb(undef); |
25abda27 |
316 | $schema->storage->debug($orig_debug); |
a54bd479 |
317 | |
318 | is_deeply ( |
319 | [map { $_->name } ($limited_rs->search_related ('owner')->all) ], |
320 | [@owner_names[2 .. 7]], |
321 | "$test_type: Rows are still properly ordered after search_related", |
322 | ); |
323 | } |
6de07ea3 |
324 | |
a54bd479 |
325 | # try a ->has_many direction with duplicates |
326 | my $owners = $schema->resultset ('Owners')->search ( |
327 | { |
328 | 'books.id' => { '!=', undef }, |
329 | 'me.name' => { '!=', 'somebogusstring' }, |
330 | }, |
331 | { |
332 | prefetch => 'books', |
333 | order_by => { -asc => \['name + ?', [ test => 'xxx' ]] }, # test bindvar propagation |
334 | rows => 3, # 8 results total |
335 | unsafe_subselect_ok => 1, |
336 | }, |
337 | ); |
338 | |
339 | my ($sql, @bind) = @${$owners->page(3)->as_query}; |
340 | is_deeply ( |
341 | \@bind, |
25abda27 |
342 | [ |
343 | $dialect eq 'Top' ? [ test => 'xxx' ] : (), # the extra re-order bind |
344 | ([ 'me.name' => 'somebogusstring' ], [ test => 'xxx' ]) x 2 # double because of the prefetch subq |
345 | ], |
a54bd479 |
346 | ); |
347 | |
348 | is ($owners->page(1)->all, 3, "$test_type: has_many prefetch returns correct number of rows"); |
349 | is ($owners->page(1)->count, 3, "$test_type: has-many prefetch returns correct count"); |
350 | |
351 | is ($owners->page(3)->count, 2, "$test_type: has-many prefetch returns correct count"); |
352 | TODO: { |
353 | local $TODO = "Top-limit does not work when your limit ends up past the resultset" |
354 | if $dialect eq 'Top'; |
355 | is ($owners->page(3)->all, 2, "$test_type: has_many prefetch returns correct number of rows"); |
356 | is ($owners->page(3)->count_rs->next, 2, "$test_type: has-many prefetch returns correct count_rs"); |
357 | } |
4bb438ca |
358 | |
a54bd479 |
359 | |
360 | # try a ->belongs_to direction (no select collapse, group_by should work) |
361 | my $books = $schema->resultset ('BooksInLibrary')->search ( |
362 | { |
363 | 'owner.name' => [qw/wiggle woggle/], |
364 | }, |
365 | { |
366 | distinct => 1, |
367 | having => \['1 = ?', [ test => 1 ] ], #test having propagation |
368 | prefetch => 'owner', |
369 | rows => 2, # 3 results total |
370 | order_by => { -desc => 'me.owner' }, |
371 | unsafe_subselect_ok => 1, |
372 | }, |
373 | ); |
374 | |
375 | ($sql, @bind) = @${$books->page(3)->as_query}; |
376 | is_deeply ( |
377 | \@bind, |
378 | [ |
379 | # inner |
380 | [ 'owner.name' => 'wiggle' ], [ 'owner.name' => 'woggle' ], [ source => 'Library' ], [ test => '1' ], |
381 | # outer |
382 | [ 'owner.name' => 'wiggle' ], [ 'owner.name' => 'woggle' ], [ source => 'Library' ], |
383 | ], |
384 | ); |
385 | |
386 | is ($books->page(1)->all, 2, "$test_type: Prefetched grouped search returns correct number of rows"); |
387 | is ($books->page(1)->count, 2, "$test_type: Prefetched grouped search returns correct count"); |
388 | |
389 | is ($books->page(2)->count, 1, "$test_type: Prefetched grouped search returns correct count"); |
390 | TODO: { |
391 | local $TODO = "Top-limit does not work when your limit ends up past the resultset" |
392 | if $dialect eq 'Top'; |
393 | is ($books->page(2)->all, 1, "$test_type: Prefetched grouped search returns correct number of rows"); |
394 | is ($books->page(2)->count_rs->next, 1, "$test_type: Prefetched grouped search returns correct count_rs"); |
395 | } |
396 | } |
6de07ea3 |
397 | } |
398 | |
399 | |
a54bd479 |
400 | # test GUID columns |
8ff60918 |
401 | { |
a54bd479 |
402 | $schema->storage->dbh_do (sub { |
403 | my ($storage, $dbh) = @_; |
404 | eval { $dbh->do("DROP TABLE artist") }; |
405 | $dbh->do(<<'SQL'); |
406 | CREATE TABLE artist ( |
407 | artistid UNIQUEIDENTIFIER NOT NULL, |
408 | name VARCHAR(100), |
409 | rank INT NOT NULL DEFAULT '13', |
410 | charfield CHAR(10) NULL, |
411 | a_guid UNIQUEIDENTIFIER, |
412 | primary key(artistid) |
413 | ) |
414 | SQL |
415 | }); |
8ff60918 |
416 | |
a54bd479 |
417 | # start disconnected to make sure insert works on an un-reblessed storage |
418 | $schema = DBICTest::Schema->connect($dsn, $user, $pass); |
8ff60918 |
419 | |
a54bd479 |
420 | my $row; |
421 | lives_ok { |
422 | $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' }) |
423 | } 'created a row with a GUID'; |
8ff60918 |
424 | |
a54bd479 |
425 | ok( |
426 | eval { $row->artistid }, |
427 | 'row has GUID PK col populated', |
8ff60918 |
428 | ); |
a54bd479 |
429 | diag $@ if $@; |
8ff60918 |
430 | |
a54bd479 |
431 | ok( |
432 | eval { $row->a_guid }, |
433 | 'row has a GUID col with auto_nextval populated', |
8ff60918 |
434 | ); |
a54bd479 |
435 | diag $@ if $@; |
8ff60918 |
436 | |
a54bd479 |
437 | my $row_from_db = $schema->resultset('ArtistGUID') |
438 | ->search({ name => 'mtfnpy' })->first; |
f0bd60fc |
439 | |
a54bd479 |
440 | is $row_from_db->artistid, $row->artistid, |
441 | 'PK GUID round trip'; |
b9a2c3a5 |
442 | |
a54bd479 |
443 | is $row_from_db->a_guid, $row->a_guid, |
444 | 'NON-PK GUID round trip'; |
445 | } |
02d133f0 |
446 | |
a54bd479 |
447 | # test MONEY type |
b9a2c3a5 |
448 | { |
a54bd479 |
449 | $schema->storage->dbh_do (sub { |
450 | my ($storage, $dbh) = @_; |
451 | eval { $dbh->do("DROP TABLE money_test") }; |
452 | $dbh->do(<<'SQL'); |
453 | CREATE TABLE money_test ( |
454 | id INT IDENTITY PRIMARY KEY, |
455 | amount MONEY NULL |
456 | ) |
457 | SQL |
458 | }); |
9010bab8 |
459 | |
a54bd479 |
460 | my $rs = $schema->resultset('Money'); |
461 | my $row; |
56d2561e |
462 | |
a54bd479 |
463 | lives_ok { |
464 | $row = $rs->create({ amount => 100 }); |
465 | } 'inserted a money value'; |
6bc666a5 |
466 | |
a54bd479 |
467 | cmp_ok $rs->find($row->id)->amount, '==', 100, 'money value round-trip'; |
b9a2c3a5 |
468 | |
a54bd479 |
469 | lives_ok { |
470 | $row->update({ amount => 200 }); |
471 | } 'updated a money value'; |
fc85215b |
472 | |
a54bd479 |
473 | cmp_ok $rs->find($row->id)->amount, '==', 200, |
474 | 'updated money value round-trip'; |
b1e1d073 |
475 | |
a54bd479 |
476 | lives_ok { |
477 | $row->update({ amount => undef }); |
478 | } 'updated a money value to NULL'; |
b1e1d073 |
479 | |
a54bd479 |
480 | is $rs->find($row->id)->amount, undef,'updated money value to NULL round-trip'; |
b9a2c3a5 |
481 | } |
c1cac633 |
482 | |
a54bd479 |
483 | |
afcfff01 |
484 | done_testing; |
485 | |
c1cac633 |
486 | # clean up our mess |
487 | END { |
ca791b95 |
488 | if (my $dbh = eval { $schema->storage->_dbh }) { |
489 | eval { $dbh->do("DROP TABLE $_") } |
02495deb |
490 | for qw/artist money_test books owners/; |
ca791b95 |
491 | } |
c1cac633 |
492 | } |
fc85215b |
493 | # vim:sw=2 sts=2 |