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