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