Switch travis-perl tests to 5.18
[dbsrgits/DBIx-Class.git] / t / 751msaccess.t
1 use strict;
2 use warnings;
3
4 use Test::More;
5 use Test::Exception;
6 use Scope::Guard ();
7 use Try::Tiny;
8 use DBIx::Class::Optional::Dependencies ();
9 use lib qw(t/lib);
10 use DBICTest;
11 use DBIC::DebugObj ();
12 use DBIC::SqlMakerTest;
13
14 my ($dsn,  $user,  $pass)  = @ENV{map { "DBICTEST_MSACCESS_ODBC_${_}" } qw/DSN USER PASS/};
15 my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_MSACCESS_ADO_${_}" }  qw/DSN USER PASS/};
16
17 plan skip_all => 'Test needs ' .
18   (join ' or ', map { $_ ? $_ : () }
19     DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_msaccess_odbc'),
20     DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_msaccess_ado'))
21   unless
22     $dsn && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_msaccess_odbc')
23     or
24     $dsn2 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_msaccess_ado')
25     or
26     (not $dsn || $dsn2);
27
28 DBICTest::Schema->load_classes('ArtistGUID');
29
30 # Example DSNs (32bit only):
31 # dbi:ODBC:driver={Microsoft Access Driver (*.mdb, *.accdb)};dbq=C:\Users\rkitover\Documents\access_sample.accdb
32 # dbi:ADO:Microsoft.Jet.OLEDB.4.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb
33 # dbi:ADO:Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb;Persist Security Info=False'
34
35 plan skip_all => <<'EOF' unless $dsn || $dsn2;
36 Set $ENV{DBICTEST_MSACCESS_ODBC_DSN} and/or $ENV{DBICTEST_MSACCESS_ADO_DSN} (and optionally _USER and _PASS) to run these tests.
37 Warning: this test drops and creates the tables 'artist', 'cd', 'bindtype_test' and 'artist_guid'.
38 EOF
39
40 my @info = (
41   [ $dsn,  $user  || '', $pass  || '' ],
42   [ $dsn2, $user2 || '', $pass2 || '' ],
43 );
44
45 foreach my $info (@info) {
46   my ($dsn, $user, $pass) = @$info;
47
48   next unless $dsn;
49
50 # Check that we can connect without any options.
51   my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
52   lives_ok {
53     $schema->storage->ensure_connected;
54   } 'connection without any options';
55
56   my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
57   $binstr{'large'} = $binstr{'small'} x 1024;
58
59   my $maxloblen = length $binstr{'large'};
60
61   $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
62     quote_names => 1,
63     auto_savepoint => 1,
64     LongReadLen => $maxloblen,
65   });
66
67   my $guard = Scope::Guard->new(sub { cleanup($schema) });
68
69   my $dbh = $schema->storage->dbh;
70
71   # turn off warnings for OLE exception from ADO about nonexistant table
72   eval { local $^W = 0; $dbh->do("DROP TABLE artist") };
73
74   $dbh->do(<<EOF);
75   CREATE TABLE artist (
76     artistid AUTOINCREMENT PRIMARY KEY,
77     name VARCHAR(255) NULL,
78     charfield CHAR(10) NULL,
79     rank INT NULL
80   )
81 EOF
82
83   my $ars = $schema->resultset('Artist');
84   is ( $ars->count, 0, 'No rows at first' );
85
86 # test primary key handling
87   my $new = $ars->create({ name => 'foo' });
88   ok($new->artistid, "Auto-PK worked");
89
90   my $first_artistid = $new->artistid;
91
92 # test explicit key spec
93   $new = $ars->create ({ name => 'bar', artistid => 66 });
94   is($new->artistid, 66, 'Explicit PK worked');
95   $new->discard_changes;
96   is($new->artistid, 66, 'Explicit PK assigned');
97
98 # test joins
99   eval { local $^W = 0; $dbh->do("DROP TABLE cd") };
100
101   $dbh->do(<<EOF);
102   CREATE TABLE cd (
103     cdid AUTOINCREMENT PRIMARY KEY,
104     artist INTEGER NULL,
105     title VARCHAR(255) NULL,
106     [year] CHAR(4) NULL,
107     genreid INTEGER NULL,
108     single_track INTEGER NULL
109   )
110 EOF
111
112   $dbh->do(<<EOF);
113   CREATE TABLE track (
114     trackid AUTOINCREMENT PRIMARY KEY,
115     cd INTEGER REFERENCES cd(cdid),
116     [position] INTEGER,
117     title VARCHAR(255),
118     last_updated_on DATETIME,
119     last_updated_at DATETIME
120   )
121 EOF
122
123   my $cd = $schema->resultset('CD')->create({
124     artist => $first_artistid,
125     title => 'Some Album',
126   });
127
128 # one-step join
129   my $joined_artist = $schema->resultset('Artist')->search({
130     artistid => $first_artistid,
131   }, {
132     join => [ 'cds' ],
133     '+select' => [ 'cds.title' ],
134     '+as'     => [ 'cd_title'  ],
135   })->next;
136
137   is $joined_artist->get_column('cd_title'), 'Some Album',
138     'one-step join works';
139
140 # two-step join
141   my $track = $schema->resultset('Track')->create({
142     cd => $cd->cdid,
143     position => 1,
144     title => 'my track',
145   });
146
147   my ($sql, @bind);
148
149   my $joined_track = try {
150     local $schema->storage->{debug} = 1;
151     local $schema->storage->{debugobj} = DBIC::DebugObj->new(\$sql, \@bind);
152
153     $schema->resultset('Artist')->search({
154       artistid => $first_artistid,
155     }, {
156       join => [{ cds => 'tracks' }],
157       '+select' => [ 'tracks.title' ],
158       '+as'     => [ 'track_title'  ],
159     })->next;
160   }
161   catch {
162     diag "Could not execute two-step left join: $_";
163   };
164
165   s/^'//, s/'\z// for @bind;
166
167   is_same_sql_bind(
168     $sql,
169     \@bind,
170     'SELECT [me].[artistid], [me].[name], [me].[rank], [me].[charfield], [tracks].[title] FROM ( ( [artist] [me] LEFT JOIN cd [cds] ON [cds].[artist] = [me].[artistid] ) LEFT JOIN [track] [tracks] ON [tracks].[cd] = [cds].[cdid] ) WHERE ( [artistid] = ? )',
171     [1],
172     'correct SQL for two-step left join',
173   );
174
175   is try { $joined_track->get_column('track_title') }, 'my track',
176     'two-step left join works';
177
178   ($sql, @bind) = ();
179
180   $joined_artist = try {
181     local $schema->storage->{debug} = 1;
182     local $schema->storage->{debugobj} = DBIC::DebugObj->new(\$sql, \@bind);
183
184     $schema->resultset('Track')->search({
185       trackid => $track->trackid,
186     }, {
187       join => [{ cd => 'artist' }],
188       '+select' => [ 'artist.name' ],
189       '+as'     => [ 'artist_name'  ],
190     })->next;
191   }
192   catch {
193     diag "Could not execute two-step inner join: $_";
194   };
195
196   s/^'//, s/'\z// for @bind;
197
198   is_same_sql_bind(
199     $sql,
200     \@bind,
201     'SELECT [me].[trackid], [me].[cd], [me].[position], [me].[title], [me].[last_updated_on], [me].[last_updated_at], [artist].[name] FROM ( ( [track] [me] INNER JOIN cd [cd] ON [cd].[cdid] = [me].[cd] ) INNER JOIN [artist] [artist] ON [artist].[artistid] = [cd].[artist] ) WHERE ( [trackid] = ? )',
202     [$track->trackid],
203     'correct SQL for two-step inner join',
204   );
205
206   is try { $joined_artist->get_column('artist_name') }, 'foo',
207     'two-step inner join works';
208
209 # test basic transactions
210   $schema->txn_do(sub {
211     $ars->create({ name => 'transaction_commit' });
212   });
213   ok($ars->search({ name => 'transaction_commit' })->first,
214     'transaction committed');
215   $ars->search({ name => 'transaction_commit' })->delete,
216   throws_ok {
217     $schema->txn_do(sub {
218       $ars->create({ name => 'transaction_rollback' });
219       die 'rolling back';
220     });
221   } qr/rolling back/, 'rollback executed';
222   is $ars->search({ name => 'transaction_rollback' })->first, undef,
223     'transaction rolled back';
224
225 # test two-phase commit and inner transaction rollback from nested transactions
226   $schema->txn_do(sub {
227     $ars->create({ name => 'in_outer_transaction' });
228     $schema->txn_do(sub {
229       $ars->create({ name => 'in_inner_transaction' });
230     });
231     ok($ars->search({ name => 'in_inner_transaction' })->first,
232       'commit from inner transaction visible in outer transaction');
233     throws_ok {
234       $schema->txn_do(sub {
235         $ars->create({ name => 'in_inner_transaction_rolling_back' });
236         die 'rolling back inner transaction';
237       });
238     } qr/rolling back inner transaction/, 'inner transaction rollback executed';
239   });
240   ok($ars->search({ name => 'in_outer_transaction' })->first,
241     'commit from outer transaction');
242   ok($ars->search({ name => 'in_inner_transaction' })->first,
243     'commit from inner transaction');
244   is $ars->search({ name => 'in_inner_transaction_rolling_back' })->first,
245     undef,
246     'rollback from inner transaction';
247   $ars->search({ name => 'in_outer_transaction' })->delete;
248   $ars->search({ name => 'in_inner_transaction' })->delete;
249
250 # test populate
251   lives_ok (sub {
252     my @pop;
253     for (1..2) {
254       push @pop, { name => "Artist_$_" };
255     }
256     $ars->populate (\@pop);
257   });
258
259 # test populate with explicit key
260   lives_ok (sub {
261     my @pop;
262     for (1..2) {
263       push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ };
264     }
265     $ars->populate (\@pop);
266   });
267
268 # count what we did so far
269   is ($ars->count, 6, 'Simple count works');
270
271 # test LIMIT support
272 # not testing offset because access only supports TOP
273   my $lim = $ars->search( {},
274     {
275       rows => 2,
276       offset => 0,
277       order_by => 'artistid'
278     }
279   );
280   is( $lim->count, 2, 'ROWS+OFFSET count ok' );
281   is( $lim->all, 2, 'Number of ->all objects matches count' );
282
283 # test iterator
284   $lim->reset;
285   is( $lim->next->artistid, 1, "iterator->next ok" );
286   is( $lim->next->artistid, 66, "iterator->next ok" );
287   is( $lim->next, undef, "next past end of resultset ok" );
288
289 # test empty insert
290   my $current_artistid = $ars->search({}, {
291     select => [ { max => 'artistid' } ], as => ['artistid']
292   })->first->artistid;
293
294   my $row;
295   lives_ok { $row = $ars->create({}) }
296     'empty insert works';
297
298   $row->discard_changes;
299
300   is $row->artistid, $current_artistid+1,
301     'empty insert generated correct PK';
302
303 # test that autoinc column still works after empty insert
304   $row = $ars->create({ name => 'after_empty_insert' });
305
306   is $row->artistid, $current_artistid+2,
307     'autoincrement column functional aftear empty insert';
308
309 # test blobs (stolen from 73oracle.t)
310
311 # turn off horrendous binary DBIC_TRACE output
312   {
313     local $schema->storage->{debug} = 0;
314
315     eval { local $^W = 0; $dbh->do('DROP TABLE bindtype_test') };
316     $dbh->do(qq[
317     CREATE TABLE bindtype_test
318     (
319       id     INT          NOT NULL PRIMARY KEY,
320       bytea  INT          NULL,
321       blob   IMAGE        NULL,
322       clob   TEXT         NULL,
323       a_memo MEMO         NULL
324     )
325     ],{ RaiseError => 1, PrintError => 1 });
326
327     my $rs = $schema->resultset('BindType');
328     my $id = 0;
329
330     foreach my $type (qw( blob clob a_memo )) {
331       foreach my $size (qw( small large )) {
332         SKIP: {
333           skip 'TEXT columns not cast to MEMO over ODBC', 2
334             if $type eq 'clob' && $size eq 'large' && $dsn =~ /:ODBC:/;
335
336           $id++;
337
338           lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
339             "inserted $size $type without dying" or next;
340
341           my $from_db = eval { $rs->find($id)->$type } || '';
342           diag $@ if $@;
343
344           ok($from_db eq $binstr{$size}, "verified inserted $size $type" )
345             or do {
346               my $hexdump = sub {
347                 join '', map sprintf('%02X', ord), split //, shift
348               };
349               diag 'Got: ', "\n", substr($hexdump->($from_db),0,255), '...',
350                 substr($hexdump->($from_db),-255);
351               diag 'Size: ', length($from_db);
352               diag 'Expected Size: ', length($binstr{$size});
353               diag 'Expected: ', "\n",
354                 substr($hexdump->($binstr{$size}), 0, 255),
355                 "...", substr($hexdump->($binstr{$size}),-255);
356             };
357         }
358       }
359     }
360 # test IMAGE update
361     lives_ok {
362       $rs->search({ id => 0 })->update({ blob => $binstr{small} });
363     } 'updated IMAGE to small binstr without dying';
364
365     lives_ok {
366       $rs->search({ id => 0 })->update({ blob => $binstr{large} });
367     } 'updated IMAGE to large binstr without dying';
368   }
369
370 # test GUIDs (and the cursor GUID fixup stuff for ADO)
371
372   require Data::GUID;
373   $schema->storage->new_guid(sub { Data::GUID->new->as_string });
374
375   local $schema->source('ArtistGUID')->column_info('artistid')->{data_type}
376     = 'guid';
377
378   local $schema->source('ArtistGUID')->column_info('a_guid')->{data_type}
379     = 'guid';
380
381   $schema->storage->dbh_do (sub {
382     my ($storage, $dbh) = @_;
383     eval { local $^W = 0; $dbh->do("DROP TABLE artist_guid") };
384     $dbh->do(<<"SQL");
385 CREATE TABLE artist_guid (
386    artistid GUID NOT NULL,
387    name VARCHAR(100),
388    rank INT NULL,
389    charfield CHAR(10) NULL,
390    a_guid GUID,
391    primary key(artistid)
392 )
393 SQL
394   });
395
396   lives_ok {
397     $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' })
398   } 'created a row with a GUID';
399
400   ok(
401     eval { $row->artistid },
402     'row has GUID PK col populated',
403   );
404   diag $@ if $@;
405
406   ok(
407     eval { $row->a_guid },
408     'row has a GUID col with auto_nextval populated',
409   );
410   diag $@ if $@;
411
412   my $row_from_db = $schema->resultset('ArtistGUID')
413     ->search({ name => 'mtfnpy' })->first;
414
415   is $row_from_db->artistid, $row->artistid,
416     'PK GUID round trip (via ->search->next)';
417
418   is $row_from_db->a_guid, $row->a_guid,
419     'NON-PK GUID round trip (via ->search->next)';
420
421   $row_from_db = $schema->resultset('ArtistGUID')
422     ->find($row->artistid);
423
424   is $row_from_db->artistid, $row->artistid,
425     'PK GUID round trip (via ->find)';
426
427   is $row_from_db->a_guid, $row->a_guid,
428     'NON-PK GUID round trip (via ->find)';
429
430   ($row_from_db) = $schema->resultset('ArtistGUID')
431     ->search({ name => 'mtfnpy' })->all;
432
433   is $row_from_db->artistid, $row->artistid,
434     'PK GUID round trip (via ->search->all)';
435
436   is $row_from_db->a_guid, $row->a_guid,
437     'NON-PK GUID round trip (via ->search->all)';
438 }
439
440 done_testing;
441
442 sub cleanup {
443   my $schema = shift;
444
445   if (my $storage = eval { $schema->storage }) {
446     # cannot drop a table if it has been used, have to reconnect first
447     $schema->storage->disconnect;
448     local $^W = 0; # for ADO OLE exceptions
449     $schema->storage->dbh->do("DROP TABLE $_")
450       for qw/artist track cd bindtype_test artist_guid/;
451   }
452 }
453
454 # vim:sts=2 sw=2: