'undef =>' isn't what one would want
[dbsrgits/DBIx-Class-Historic.git] / t / 746mssql.t
1 use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_mssql_odbc';
2
3 use strict;
4 use warnings;
5
6 use Test::More;
7 use Test::Exception;
8 use Try::Tiny;
9
10 use lib qw(t/lib);
11 use DBICTest;
12
13 my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/};
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 $schema->storage->_dbh->disconnect;
41
42 lives_ok {
43   $schema->storage->dbh_do(sub { $_[1]->do('select 1') })
44 } '_ping works';
45
46 my %opts = (
47   use_mars =>
48     { opts => { on_connect_call => 'use_mars' } },
49   use_dynamic_cursors =>
50     { opts => { on_connect_call => 'use_dynamic_cursors' },
51       required => $schema->storage->_using_freetds ? 0 : 1,
52     },
53   use_server_cursors =>
54     { opts => { on_connect_call => 'use_server_cursors' } },
55   plain =>
56     { opts => {}, required => 1 },
57 );
58
59 for my $opts_name (keys %opts) {
60   SKIP: {
61     my $opts = $opts{$opts_name}{opts};
62     $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts);
63
64     try {
65       $schema->storage->ensure_connected
66     }
67     catch {
68       if ($opts{$opts_name}{required}) {
69         die "on_connect_call option '$opts_name' is not functional: $_";
70       }
71       else {
72         skip
73           "on_connect_call option '$opts_name' not functional in this configuration: $_",
74           1
75         ;
76       }
77     };
78
79     $schema->storage->dbh_do (sub {
80         my ($storage, $dbh) = @_;
81         eval { $dbh->do("DROP TABLE artist") };
82         $dbh->do(<<'SQL');
83 CREATE TABLE artist (
84    artistid INT IDENTITY NOT NULL,
85    name VARCHAR(100),
86    rank INT NOT NULL DEFAULT '13',
87    charfield CHAR(10) NULL,
88    primary key(artistid)
89 )
90 SQL
91     });
92
93 # test Auto-PK
94     $schema->resultset('Artist')->search({ name => 'foo' })->delete;
95
96     my $new = $schema->resultset('Artist')->create({ name => 'foo' });
97
98     ok(($new->artistid||0) > 0, "Auto-PK worked for $opts_name");
99
100 # Test multiple active statements
101     SKIP: {
102       skip 'not a multiple active statements configuration', 1
103         if $opts_name eq 'plain';
104
105       $schema->storage->ensure_connected;
106
107       lives_ok {
108
109         no warnings 'redefine';
110         local *DBI::connect = sub { die "NO RECONNECTS!!!" };
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         is($artist_rs->count, 0, '$dbh still viable');
138       } "Multiple active statements survive $opts_name";
139     }
140
141 # Test populate
142
143     {
144       $schema->storage->dbh_do (sub {
145         my ($storage, $dbh) = @_;
146         eval { $dbh->do("DROP TABLE owners") };
147         eval { $dbh->do("DROP TABLE books") };
148         $dbh->do(<<'SQL');
149 CREATE TABLE books (
150    id INT IDENTITY (1, 1) NOT NULL,
151    source VARCHAR(100),
152    owner INT,
153    title VARCHAR(10),
154    price INT NULL
155 )
156
157 CREATE TABLE owners (
158    id INT IDENTITY (1, 1) NOT NULL,
159    name VARCHAR(100),
160 )
161 SQL
162       });
163
164       lives_ok ( sub {
165         # start a new connection, make sure rebless works
166         my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts);
167         $schema->populate ('Owners', [
168           [qw/id  name  /],
169           [qw/1   wiggle/],
170           [qw/2   woggle/],
171           [qw/3   boggle/],
172           [qw/4   fRIOUX/],
173           [qw/5   fRUE/],
174           [qw/6   fREW/],
175           [qw/7   fROOH/],
176           [qw/8   fISMBoC/],
177           [qw/9   station/],
178           [qw/10   mirror/],
179           [qw/11   dimly/],
180           [qw/12   face_to_face/],
181           [qw/13   icarus/],
182           [qw/14   dream/],
183           [qw/15   dyrstyggyr/],
184         ]);
185       }, 'populate with PKs supplied ok' );
186
187
188       lives_ok (sub {
189         # start a new connection, make sure rebless works
190         # test an insert with a supplied identity, followed by one without
191         my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts);
192         for (2, 1) {
193           my $id = $_ * 20 ;
194           $schema->resultset ('Owners')->create ({ id => $id, name => "troglodoogle $id" });
195           $schema->resultset ('Owners')->create ({ name => "troglodoogle " . ($id + 1) });
196         }
197       }, 'create with/without PKs ok' );
198
199       is ($schema->resultset ('Owners')->count, 19, 'owner rows really in db' );
200
201       lives_ok ( sub {
202         # start a new connection, make sure rebless works
203         my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts);
204         $schema->populate ('BooksInLibrary', [
205           [qw/source  owner title   /],
206           [qw/Library 1     secrets0/],
207           [qw/Library 1     secrets1/],
208           [qw/Eatery  1     secrets2/],
209           [qw/Library 2     secrets3/],
210           [qw/Library 3     secrets4/],
211           [qw/Eatery  3     secrets5/],
212           [qw/Library 4     secrets6/],
213           [qw/Library 5     secrets7/],
214           [qw/Eatery  5     secrets8/],
215           [qw/Library 6     secrets9/],
216           [qw/Library 7     secrets10/],
217           [qw/Eatery  7     secrets11/],
218           [qw/Library 8     secrets12/],
219         ]);
220       }, 'populate without PKs supplied ok' );
221     }
222
223 # test simple, complex LIMIT and limited prefetch support, with both dialects and quote combinations (if possible)
224     for my $dialect (
225       'Top',
226       ($schema->storage->_server_info->{normalized_dbms_version} || 0 ) >= 9
227         ? ('RowNumberOver')
228         : ()
229       ,
230     ) {
231       for my $quoted (0, 1) {
232
233         $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
234             limit_dialect => $dialect,
235             %$opts,
236             $quoted
237               ? ( quote_char => [ qw/ [ ] / ], name_sep => '.' )
238               : ()
239             ,
240           });
241
242         my $test_type = "Dialect:$dialect Quoted:$quoted";
243
244         # basic limit support
245         {
246           my $art_rs = $schema->resultset ('Artist');
247           $art_rs->delete;
248           $art_rs->create({ name => 'Artist ' . $_ }) for (1..6);
249
250           my $it = $schema->resultset('Artist')->search( {}, {
251             rows => 4,
252             offset => 3,
253             order_by => 'artistid',
254           });
255
256           is( $it->count, 3, "$test_type: LIMIT count ok" );
257
258           local $TODO = "Top-limit does not work when your limit ends up past the resultset"
259             if $dialect eq 'Top';
260
261           is( $it->next->name, 'Artist 4', "$test_type: iterator->next ok" );
262           $it->next;
263           is( $it->next->name, 'Artist 6', "$test_type: iterator->next ok" );
264           is( $it->next, undef, "$test_type: next past end of resultset ok" );
265         }
266
267         # plain ordered subqueries throw
268         throws_ok (sub {
269           $schema->resultset('Owners')->search ({}, { order_by => 'name' })->as_query
270         }, qr/ordered subselect encountered/, "$test_type: Ordered Subselect detection throws ok");
271
272         # make sure ordered subselects *somewhat* work
273         {
274           my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 });
275           my $sealed_owners = $owners->as_subselect_rs;
276
277           is_deeply (
278             [ sort map { $_->name } ($sealed_owners->all) ],
279             [ sort map { $_->name } ($owners->all) ],
280             "$test_type: Sort preserved from within a subquery",
281           );
282         }
283
284         # still even with lost order of IN, we should be getting correct
285         # sets
286         {
287           my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 });
288           my $corelated_owners = $owners->result_source->resultset->search (
289             {
290               id => { -in => $owners->get_column('id')->as_query },
291             },
292             {
293               order_by => 'name' #reorder because of what is shown above
294             },
295           );
296
297           is (
298             join ("\x00", map { $_->name } ($corelated_owners->all) ),
299             join ("\x00", map { $_->name } ($owners->all) ),
300             "$test_type: With an outer order_by, everything still matches",
301           );
302         }
303
304         # make sure right-join-side single-prefetch ordering limit works
305         {
306           my $rs = $schema->resultset ('BooksInLibrary')->search (
307             {
308               'owner.name' => { '!=', 'woggle' },
309             },
310             {
311               prefetch => 'owner',
312               order_by => 'owner.name',
313             }
314           );
315           # this is the order in which they should come from the above query
316           my @owner_names = qw/boggle fISMBoC fREW fRIOUX fROOH fRUE wiggle wiggle/;
317
318           is ($rs->all, 8, "$test_type: Correct amount of objects from right-sorted joined resultset");
319           is_deeply (
320             [map { $_->owner->name } ($rs->all) ],
321             \@owner_names,
322             "$test_type: Prefetched rows were properly ordered"
323           );
324
325           my $limited_rs = $rs->search ({}, {rows => 6, offset => 2, unsafe_subselect_ok => 1});
326           is ($limited_rs->count, 6, "$test_type: Correct count of limited right-sorted joined resultset");
327           is ($limited_rs->count_rs->next, 6, "$test_type: Correct count_rs of limited right-sorted joined resultset");
328
329           $schema->is_executed_querycount( sub {
330             is_deeply (
331               [map { $_->owner->name } ($limited_rs->all) ],
332               [@owner_names[2 .. 7]],
333               "$test_type: Prefetch-limited rows were properly ordered"
334             );
335           }, 1, "$test_type: Only one query with prefetch" );
336
337           is_deeply (
338             [map { $_->name } ($limited_rs->search_related ('owner')->all) ],
339             [@owner_names[2 .. 7]],
340             "$test_type: Rows are still properly ordered after search_related",
341           );
342         }
343
344         # try a ->has_many direction with duplicates
345         my $owners = $schema->resultset ('Owners')->search (
346           {
347             'books.id' => { '!=', undef },
348             'me.name' => { '!=', 'somebogusstring' },
349           },
350           {
351             prefetch => 'books',
352             order_by => [ { -asc => \['name + ?', [ test => 'xxx' ]] }, 'me.id' ], # test bindvar propagation
353             group_by => [ map { "me.$_" } $schema->source('Owners')->columns ], # the literal order_by requires an explicit group_by
354             rows     => 3,  # 8 results total
355             unsafe_subselect_ok => 1,
356           },
357         );
358
359         is ($owners->page(1)->all, 3, "$test_type: has_many prefetch returns correct number of rows");
360         is ($owners->page(1)->count, 3, "$test_type: has-many prefetch returns correct count");
361
362         is ($owners->page(3)->count, 2, "$test_type: has-many prefetch returns correct count");
363         {
364           local $TODO = "Top-limit does not work when your limit ends up past the resultset"
365             if $dialect eq 'Top';
366           is ($owners->page(3)->all, 2, "$test_type: has_many prefetch returns correct number of rows");
367           is ($owners->page(3)->count_rs->next, 2, "$test_type: has-many prefetch returns correct count_rs");
368         }
369
370
371         # try a ->belongs_to direction (no select collapse, group_by should work)
372         my $books = $schema->resultset ('BooksInLibrary')->search (
373           {
374             'owner.name' => [qw/wiggle woggle/],
375           },
376           {
377             distinct => 1,
378             having => \['1 = ?', [ test => 1 ] ], #test having propagation
379             prefetch => 'owner',
380             rows     => 2,  # 3 results total
381             order_by => [{ -desc => 'me.owner' }, 'me.id'],
382             unsafe_subselect_ok => 1,
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         {
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       }
397     }
398
399
400 # test GUID columns
401     {
402       $schema->storage->dbh_do (sub {
403         my ($storage, $dbh) = @_;
404         eval { $dbh->do("DROP TABLE artist_guid") };
405         $dbh->do(<<'SQL');
406 CREATE TABLE artist_guid (
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       });
416
417       # start disconnected to make sure insert works on an un-reblessed storage
418       $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts);
419
420       my $row;
421       lives_ok {
422         $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' })
423       } 'created a row with a GUID';
424
425       ok(
426         eval { $row->artistid },
427         'row has GUID PK col populated',
428       );
429       diag $@ if $@;
430
431       ok(
432         eval { $row->a_guid },
433         'row has a GUID col with auto_nextval populated',
434       );
435       diag $@ if $@;
436
437       my $row_from_db = $schema->resultset('ArtistGUID')
438         ->search({ name => 'mtfnpy' })->first;
439
440       is $row_from_db->artistid, $row->artistid,
441         'PK GUID round trip';
442
443       is $row_from_db->a_guid, $row->a_guid,
444         'NON-PK GUID round trip';
445     }
446
447 # test MONEY type
448     {
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       });
459
460       {
461         my $freetds_and_dynamic_cursors = 1
462           if $opts_name eq 'use_dynamic_cursors' &&
463             $schema->storage->_using_freetds;
464
465         local $TODO =
466 'these tests fail on freetds with dynamic cursors for some reason'
467           if $freetds_and_dynamic_cursors;
468         local $ENV{DBIC_NULLABLE_KEY_NOWARN} = 1
469           if $freetds_and_dynamic_cursors;
470
471         my $rs = $schema->resultset('Money');
472         my $row;
473
474         lives_ok {
475           $row = $rs->create({ amount => 100 });
476         } 'inserted a money value';
477
478         cmp_ok ((try { $rs->find($row->id)->amount })||0, '==', 100,
479           'money value round-trip');
480
481         lives_ok {
482           $row->update({ amount => 200 });
483         } 'updated a money value';
484
485         cmp_ok ((try { $rs->find($row->id)->amount })||0, '==', 200,
486           'updated money value round-trip');
487
488         lives_ok {
489           $row->update({ amount => undef });
490         } 'updated a money value to NULL';
491
492         is try { $rs->find($row->id)->amount }, undef,
493           'updated money value to NULL round-trip';
494       }
495     }
496   }
497 }
498
499 done_testing;
500
501 # clean up our mess
502 END {
503   if (my $dbh = eval { $schema->storage->_dbh }) {
504     eval { $dbh->do("DROP TABLE $_") }
505       for qw/artist artist_guid money_test books owners/;
506   }
507   undef $schema;
508 }
509 # vim:sw=2 sts=2