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