Commit | Line | Data |
3a8aae80 |
1 | use strict; |
2 | use warnings; |
3 | |
4 | use Test::More; |
5 | use Test::Exception; |
199fbc45 |
6 | use DBIx::Class::Optional::Dependencies (); |
5346c8ff |
7 | use Scope::Guard (); |
8 | use Try::Tiny; |
3a8aae80 |
9 | use lib qw(t/lib); |
10 | use DBICTest; |
11 | |
49b3a264 |
12 | my $env2optdep = { |
13 | DBICTEST_FIREBIRD => 'test_rdbms_firebird', |
14 | DBICTEST_FIREBIRD_INTERBASE => 'test_rdbms_firebird_interbase', |
15 | DBICTEST_FIREBIRD_ODBC => 'test_rdbms_firebird_odbc', |
16 | }; |
17 | |
18 | plan skip_all => join (' ', |
19 | 'Set $ENV{DBICTEST_FIREBIRD_DSN} and/or $ENV{DBICTEST_FIREBIRD_INTERBASE_DSN}', |
20 | 'and/or $ENV{DBICTEST_FIREBIRD_ODBC_DSN},', |
21 | '_USER and _PASS to run these tests.', |
22 | |
23 | 'WARNING: this test creates and drops the tables "artist", "bindtype_test" and', |
24 | '"sequence_test"; the generators "gen_artist_artistid", "pkid1_seq", "pkid2_seq"', |
25 | 'and "nonpkid_seq" and the trigger "artist_bi".', |
26 | ) unless grep { $ENV{"${_}_DSN"} } keys %$env2optdep; |
3a8aae80 |
27 | |
199fbc45 |
28 | # tests stolen from 749sybase_asa.t |
3a8aae80 |
29 | |
f7e5fd18 |
30 | # Example DSNs: |
f7e5fd18 |
31 | # dbi:Firebird:db=/var/lib/firebird/2.5/data/hlaghdb.fdb |
199fbc45 |
32 | # dbi:InterBase:db=/var/lib/firebird/2.5/data/hlaghdb.fdb |
f7e5fd18 |
33 | |
34 | # Example ODBC DSN: |
35 | # dbi:ODBC:Driver=Firebird;Dbname=/var/lib/firebird/2.5/data/hlaghdb.fdb |
36 | |
145b2a3d |
37 | my $schema; |
3a8aae80 |
38 | |
dabde0bc |
39 | my @test_order = map { "DBICTEST_FIREBIRD$_" } |
40 | DBICTest::RunMode->is_plain |
41 | ? ('', '_INTERBASE', '_ODBC') # Least likely to fail |
42 | : ('_ODBC', '_INTERBASE' , ''); # Most likely to fail |
43 | |
44 | for my $prefix (@test_order) { SKIP: { |
49b3a264 |
45 | |
46 | my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/; |
3a8aae80 |
47 | |
48 | next unless $dsn; |
49 | |
e78660c7 |
50 | note "Testing with ${prefix}_DSN"; |
51 | |
49b3a264 |
52 | skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1) |
53 | unless DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix}); |
54 | |
dabde0bc |
55 | skip ("DBD::InterBase crashes if Firebird or ODBC are also loaded", 1) |
56 | if $prefix eq 'DBICTEST_FIREBIRD_INTERBASE' and |
57 | ($ENV{DBICTEST_FIREBIRD_DSN} or $ENV{DBICTEST_FIREBIRD_ODBC_DSN}); |
58 | |
32323fc2 |
59 | $schema = DBICTest::Schema->connect($dsn, $user, $pass, { |
dd2109ee |
60 | auto_savepoint => 1, |
5346c8ff |
61 | quote_names => 1, |
e46df41a |
62 | ($dsn !~ /ODBC/ ? (on_connect_call => 'use_softcommit') : ()), |
32323fc2 |
63 | }); |
3a8aae80 |
64 | my $dbh = $schema->storage->dbh; |
65 | |
65d35121 |
66 | my $sg = Scope::Guard->new(sub { cleanup($schema) }); |
3a8aae80 |
67 | |
930689e6 |
68 | eval { $dbh->do(q[DROP TABLE "artist"]) }; |
3a8aae80 |
69 | $dbh->do(<<EOF); |
930689e6 |
70 | CREATE TABLE "artist" ( |
71 | "artistid" INT PRIMARY KEY, |
72 | "name" VARCHAR(255), |
73 | "charfield" CHAR(10), |
74 | "rank" INT DEFAULT 13 |
3a8aae80 |
75 | ) |
76 | EOF |
930689e6 |
77 | eval { $dbh->do(q[DROP GENERATOR "gen_artist_artistid"]) }; |
78 | $dbh->do('CREATE GENERATOR "gen_artist_artistid"'); |
79 | eval { $dbh->do('DROP TRIGGER "artist_bi"') }; |
3a8aae80 |
80 | $dbh->do(<<EOF); |
930689e6 |
81 | CREATE TRIGGER "artist_bi" FOR "artist" |
3a8aae80 |
82 | ACTIVE BEFORE INSERT POSITION 0 |
83 | AS |
84 | BEGIN |
930689e6 |
85 | IF (NEW."artistid" IS NULL) THEN |
86 | NEW."artistid" = GEN_ID("gen_artist_artistid",1); |
3a8aae80 |
87 | END |
88 | EOF |
e1958268 |
89 | eval { $dbh->do('DROP TABLE "sequence_test"') }; |
90 | $dbh->do(<<EOF); |
91 | CREATE TABLE "sequence_test" ( |
92 | "pkid1" INT NOT NULL, |
93 | "pkid2" INT NOT NULL, |
94 | "nonpkid" INT, |
95 | "name" VARCHAR(255) |
96 | ) |
97 | EOF |
98 | $dbh->do('ALTER TABLE "sequence_test" ADD CONSTRAINT "sequence_test_constraint" PRIMARY KEY ("pkid1", "pkid2")'); |
99 | eval { $dbh->do('DROP GENERATOR "pkid1_seq"') }; |
07cda1c5 |
100 | eval { $dbh->do('DROP GENERATOR pkid2_seq') }; |
e1958268 |
101 | eval { $dbh->do('DROP GENERATOR "nonpkid_seq"') }; |
102 | $dbh->do('CREATE GENERATOR "pkid1_seq"'); |
07cda1c5 |
103 | $dbh->do('CREATE GENERATOR pkid2_seq'); |
104 | $dbh->do('SET GENERATOR pkid2_seq TO 9'); |
e1958268 |
105 | $dbh->do('CREATE GENERATOR "nonpkid_seq"'); |
106 | $dbh->do('SET GENERATOR "nonpkid_seq" TO 19'); |
3a8aae80 |
107 | |
108 | my $ars = $schema->resultset('Artist'); |
109 | is ( $ars->count, 0, 'No rows at first' ); |
110 | |
111 | # test primary key handling |
112 | my $new = $ars->create({ name => 'foo' }); |
113 | ok($new->artistid, "Auto-PK worked"); |
114 | |
e1958268 |
115 | # test auto increment using generators WITHOUT triggers |
116 | for (1..5) { |
117 | my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' }); |
118 | is($st->pkid1, $_, "Firebird Auto-PK without trigger: First primary key"); |
119 | is($st->pkid2, $_ + 9, "Firebird Auto-PK without trigger: Second primary key"); |
120 | is($st->nonpkid, $_ + 19, "Firebird Auto-PK without trigger: Non-primary key"); |
121 | } |
122 | my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 }); |
123 | is($st->pkid1, 55, "Firebird Auto-PK without trigger: First primary key set manually"); |
124 | |
e02b39b4 |
125 | # test transaction commit |
126 | $schema->txn_do(sub { |
127 | $ars->create({ name => 'in_transaction' }); |
128 | }); |
129 | ok (($ars->search({ name => 'in_transaction' })->first), |
130 | 'transaction committed'); |
131 | is $schema->storage->_dbh->{AutoCommit}, 1, |
132 | '$dbh->{AutoCommit} is correct after transaction commit'; |
133 | |
134 | $ars->search({ name => 'in_transaction' })->delete; |
135 | |
32323fc2 |
136 | # test savepoints |
b9889595 |
137 | throws_ok { |
a499b173 |
138 | $schema->txn_do(sub { |
e78660c7 |
139 | my ($schema, $ars) = @_; |
a499b173 |
140 | eval { |
141 | $schema->txn_do(sub { |
142 | $ars->create({ name => 'in_savepoint' }); |
143 | die "rolling back savepoint"; |
144 | }); |
145 | }; |
146 | ok ((not $ars->search({ name => 'in_savepoint' })->first), |
147 | 'savepoint rolled back'); |
148 | $ars->create({ name => 'in_outer_txn' }); |
149 | die "rolling back outer txn"; |
e78660c7 |
150 | }, $schema, $ars); |
b9889595 |
151 | } qr/rolling back outer txn/, |
5c6ed0b5 |
152 | 'correct exception for rollback'; |
153 | |
e02b39b4 |
154 | is $schema->storage->_dbh->{AutoCommit}, 1, |
155 | '$dbh->{AutoCommit} is correct after transaction rollback'; |
156 | |
a499b173 |
157 | ok ((not $ars->search({ name => 'in_outer_txn' })->first), |
158 | 'outer txn rolled back'); |
32323fc2 |
159 | |
3a8aae80 |
160 | # test explicit key spec |
161 | $new = $ars->create ({ name => 'bar', artistid => 66 }); |
162 | is($new->artistid, 66, 'Explicit PK worked'); |
163 | $new->discard_changes; |
164 | is($new->artistid, 66, 'Explicit PK assigned'); |
165 | |
e1958268 |
166 | # row update |
babd3d8e |
167 | lives_ok { |
168 | $new->update({ name => 'baz' }) |
169 | } 'update survived'; |
170 | $new->discard_changes; |
171 | is $new->name, 'baz', 'row updated'; |
172 | |
3a8aae80 |
173 | # test populate |
174 | lives_ok (sub { |
175 | my @pop; |
176 | for (1..2) { |
177 | push @pop, { name => "Artist_$_" }; |
178 | } |
179 | $ars->populate (\@pop); |
180 | }); |
181 | |
182 | # test populate with explicit key |
183 | lives_ok (sub { |
184 | my @pop; |
185 | for (1..2) { |
186 | push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ }; |
187 | } |
17d59d97 |
188 | $ars->populate (\@pop); |
3a8aae80 |
189 | }); |
190 | |
191 | # count what we did so far |
192 | is ($ars->count, 6, 'Simple count works'); |
193 | |
e1958268 |
194 | # test ResultSet UPDATE |
17d59d97 |
195 | lives_and { |
196 | $ars->search({ name => 'foo' })->update({ rank => 4 }); |
197 | |
dd2109ee |
198 | is eval { $ars->search({ name => 'foo' })->first->rank }, 4; |
72537d31 |
199 | } 'Can update a column'; |
200 | |
201 | my ($updated) = $schema->resultset('Artist')->search({name => 'foo'}); |
dd2109ee |
202 | is eval { $updated->rank }, 4, 'and the update made it to the database'; |
72537d31 |
203 | |
3a8aae80 |
204 | # test LIMIT support |
205 | my $lim = $ars->search( {}, |
206 | { |
207 | rows => 3, |
208 | offset => 4, |
209 | order_by => 'artistid' |
210 | } |
211 | ); |
212 | is( $lim->count, 2, 'ROWS+OFFSET count ok' ); |
213 | is( $lim->all, 2, 'Number of ->all objects matches count' ); |
214 | |
215 | # test iterator |
216 | $lim->reset; |
dd2109ee |
217 | is( eval { $lim->next->artistid }, 101, "iterator->next ok" ); |
218 | is( eval { $lim->next->artistid }, 102, "iterator->next ok" ); |
3a8aae80 |
219 | is( $lim->next, undef, "next past end of resultset ok" ); |
220 | |
5346c8ff |
221 | # test bug in paging |
222 | my $paged = $ars->search({ name => { -like => 'Artist%' } }, { |
223 | page => 1, |
224 | rows => 2, |
225 | order_by => 'artistid', |
226 | }); |
227 | |
228 | my $row; |
229 | lives_ok { |
230 | $row = $paged->next; |
231 | } 'paged query survived'; |
232 | |
233 | is try { $row->artistid }, 5, 'correct row from paged query'; |
234 | |
235 | # DBD bug - if any unfinished statements are present during |
236 | # DDL manipulation (test blobs below)- a segfault will occur |
237 | $paged->reset; |
238 | |
b9889595 |
239 | # test nested cursors |
17d59d97 |
240 | { |
241 | my $rs1 = $ars->search({}, { order_by => { -asc => 'artistid' }}); |
17d59d97 |
242 | |
b9889595 |
243 | my $rs2 = $ars->search({ artistid => $rs1->next->artistid }, { |
244 | order_by => { -desc => 'artistid' } |
245 | }); |
246 | |
247 | is $rs2->next->artistid, 1, 'nested cursors'; |
17d59d97 |
248 | } |
249 | |
3a8aae80 |
250 | # test empty insert |
28d28903 |
251 | lives_and { |
252 | my $row = $ars->create({}); |
253 | ok $row->artistid; |
254 | } 'empty insert works'; |
255 | |
256 | # test inferring the generator from the trigger source and using it with |
257 | # auto_nextval |
3a8aae80 |
258 | { |
28d28903 |
259 | local $ars->result_source->column_info('artistid')->{auto_nextval} = 1; |
3a8aae80 |
260 | |
28d28903 |
261 | lives_and { |
262 | my $row = $ars->create({ name => 'introspecting generator' }); |
263 | ok $row->artistid; |
264 | } 'inferring generator from trigger source works'; |
3a8aae80 |
265 | } |
266 | |
a2f22854 |
267 | # at this point there should be no active statements |
268 | # (finish() was called everywhere, either explicitly via |
269 | # reset() or on DESTROY) |
270 | for (keys %{$schema->storage->dbh->{CachedKids}}) { |
271 | fail("Unreachable cached statement still active: $_") |
272 | if $schema->storage->dbh->{CachedKids}{$_}->FETCH('Active'); |
273 | } |
274 | |
3a8aae80 |
275 | # test blobs (stolen from 73oracle.t) |
ba19fccc |
276 | eval { $dbh->do('DROP TABLE "bindtype_test"') }; |
e1958268 |
277 | $dbh->do(q[ |
ba19fccc |
278 | CREATE TABLE "bindtype_test" |
e1958268 |
279 | ( |
280 | "id" INT PRIMARY KEY, |
281 | "bytea" INT, |
ba19fccc |
282 | "blob" BLOB, |
f3a9ea3d |
283 | "clob" BLOB SUB_TYPE TEXT, |
284 | "a_memo" INT |
e1958268 |
285 | ) |
286 | ]); |
287 | |
288 | my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) ); |
289 | $binstr{'large'} = $binstr{'small'} x 1024; |
290 | |
291 | my $maxloblen = length $binstr{'large'}; |
292 | local $dbh->{'LongReadLen'} = $maxloblen; |
293 | |
ba19fccc |
294 | my $rs = $schema->resultset('BindType'); |
e1958268 |
295 | my $id = 0; |
296 | |
ba19fccc |
297 | foreach my $type (qw( blob clob )) { |
e1958268 |
298 | foreach my $size (qw( small large )) { |
299 | $id++; |
3a8aae80 |
300 | |
301 | # turn off horrendous binary DBIC_TRACE output |
e1958268 |
302 | local $schema->storage->{debug} = 0; |
3a8aae80 |
303 | |
e1958268 |
304 | lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) } |
305 | "inserted $size $type without dying"; |
3a8aae80 |
306 | |
cdf7f026 |
307 | my $got = $rs->find($id)->$type; |
308 | |
309 | my $hexdump = sub { join '', map sprintf('%02X', ord), split //, shift }; |
310 | |
311 | ok($got eq $binstr{$size}, "verified inserted $size $type" ) |
312 | or do { |
313 | diag "For " . (ref $schema->storage) . "\n"; |
314 | diag "Got blob:\n"; |
315 | diag $hexdump->(substr($got,0,50)); |
316 | diag "Expecting blob:\n"; |
317 | diag $hexdump->(substr($binstr{$size},0,50)); |
318 | }; |
3a8aae80 |
319 | } |
320 | } |
49b3a264 |
321 | }} |
3a8aae80 |
322 | |
323 | done_testing; |
324 | |
325 | # clean up our mess |
dff4c3a3 |
326 | |
327 | sub cleanup { |
65d35121 |
328 | my $schema = shift; |
329 | |
145b2a3d |
330 | my $dbh; |
331 | eval { |
332 | $schema->storage->disconnect; # to avoid object FOO is in use errors |
333 | $dbh = $schema->storage->dbh; |
334 | }; |
335 | return unless $dbh; |
336 | |
930689e6 |
337 | eval { $dbh->do('DROP TRIGGER "artist_bi"') }; |
145b2a3d |
338 | diag $@ if $@; |
339 | |
07cda1c5 |
340 | foreach my $generator (qw/ |
341 | "gen_artist_artistid" |
342 | "pkid1_seq" |
343 | pkid2_seq |
344 | "nonpkid_seq" |
345 | /) { |
346 | eval { $dbh->do(qq{DROP GENERATOR $generator}) }; |
e1958268 |
347 | diag $@ if $@; |
348 | } |
145b2a3d |
349 | |
5346c8ff |
350 | foreach my $table (qw/artist sequence_test/) { |
9633951d |
351 | eval { $dbh->do(qq[DROP TABLE "$table"]) }; |
e1958268 |
352 | diag $@ if $@; |
3a8aae80 |
353 | } |
5346c8ff |
354 | |
355 | eval { $dbh->do(q{DROP TABLE "bindtype_test"}) }; |
356 | diag $@ if $@; |
3a8aae80 |
357 | } |