Commit | Line | Data |
c0329273 |
1 | BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } |
2 | |
a4b2f17b |
3 | use strict; |
a4b2f17b |
4 | use warnings; |
5 | |
56166f36 |
6 | use Test::More; |
7 | use Test::Warn; |
8 | use Test::Exception; |
a4b2f17b |
9 | |
08a8d8f1 |
10 | use DBICTest::Util 'PEEPEENESS'; |
0d8817bc |
11 | use DBICTest; |
56166f36 |
12 | |
534521da |
13 | for my $conn_args ( |
14 | [ on_connect_do => "_NOPE_" ], |
15 | [ on_connect_call => sub { shift->_dbh->do("_NOPE_") } ], |
16 | [ on_connect_call => "_NOPE_" ], |
17 | ) { |
18 | for my $method (qw( ensure_connected _server_info _get_server_version _get_dbh )) { |
19 | |
20 | my $s = DBICTest->init_schema( |
21 | no_deploy => 1, |
22 | on_disconnect_call => sub { fail 'Disconnector should not be invoked' }, |
23 | @$conn_args |
24 | ); |
25 | |
26 | my $storage = $s->storage; |
27 | $storage = $storage->master if $ENV{DBICTEST_VIA_REPLICATED}; |
28 | |
29 | ok( ! $storage->connected, 'Starting unconnected' ); |
30 | |
31 | my $desc = "calling $method with broken on_connect action @{[ explain $conn_args ]}"; |
32 | |
33 | throws_ok { $storage->$method } |
34 | qr/ _NOPE_ \b/x, |
35 | "Throwing correctly when $desc"; |
36 | |
37 | ok( ! $storage->connected, "Still not connected after $desc" ); |
38 | |
39 | # this checks that the on_disconect_call FAIL won't trigger |
40 | $storage->disconnect; |
41 | } |
42 | } |
43 | |
44 | for my $conn_args ( |
45 | [ on_disconnect_do => "_NOPE_" ], |
46 | [ on_disconnect_call => sub { shift->_dbh->do("_NOPE_") } ], |
47 | [ on_disconnect_call => "_NOPE_" ], |
48 | ) { |
49 | my $s = DBICTest->init_schema( no_deploy => 1, @$conn_args ); |
50 | |
51 | my $storage = $s->storage; |
52 | $storage = $storage->master if $ENV{DBICTEST_VIA_REPLICATED}; |
53 | |
54 | my $desc = "broken on_disconnect action @{[ explain $conn_args ]}"; |
55 | |
56 | # connect + ping |
57 | my $dbh = $storage->dbh; |
58 | |
59 | ok ($dbh->FETCH('Active'), 'Freshly connected DBI handle is healthy'); |
60 | |
61 | warnings_exist { eval { $storage->disconnect } } [ |
62 | qr/\QDisconnect action failed\E .+ _NOPE_ \b/x |
63 | ], "Found warning of failed $desc"; |
64 | |
65 | ok (! $dbh->FETCH('Active'), "Actual DBI disconnect was not prevented by $desc" ); |
66 | } |
67 | |
e60dc79f |
68 | my $schema = DBICTest->init_schema; |
a4b2f17b |
69 | |
56166f36 |
70 | warnings_are ( sub { |
b720efd1 |
71 | throws_ok ( |
72 | sub { |
73 | $schema->resultset('CD')->create({ title => 'vacation in antarctica' }) |
74 | }, |
ed5550d3 |
75 | qr/DBI Exception.+(?x: |
76 | \QNOT NULL constraint failed: cd.artist\E |
77 | | |
78 | \Qcd.artist may not be NULL\E |
79 | )/s |
b720efd1 |
80 | ); # as opposed to some other error |
56166f36 |
81 | }, [], 'No warnings besides exception' ); |
a4b2f17b |
82 | |
b720efd1 |
83 | my $dbh = $schema->storage->dbh; |
84 | |
85 | throws_ok ( |
86 | sub { |
87 | $dbh->do ('INSERT INTO nonexistent_table VALUES (1)') |
88 | }, |
0007aedf |
89 | qr/DBI Exception.+no such table.+nonexistent_table/s, |
b720efd1 |
90 | 'DBI exceptions properly handled by dbic-installed callback' |
91 | ); |
92 | |
68fe9141 |
93 | # This usage is a bit unusual but it was actually seen in the wild |
b720efd1 |
94 | # destruction of everything except the $dbh should use the proper |
95 | # exception fallback: |
96 | |
cc1924ac |
97 | SKIP: { |
08a8d8f1 |
98 | skip "Your perl version $] appears to leak like a sieve - skipping garbage collected \$schema test", 1 |
99 | if PEEPEENESS; |
cc1924ac |
100 | |
b720efd1 |
101 | undef ($schema); |
102 | throws_ok ( |
103 | sub { |
104 | $dbh->do ('INSERT INTO nonexistent_table VALUES (1)') |
105 | }, |
0007aedf |
106 | qr/DBI Exception.+unhandled by DBIC.+no such table.+nonexistent_table/s, |
b720efd1 |
107 | 'callback works after $schema is gone' |
108 | ); |
109 | } |
110 | |
56166f36 |
111 | done_testing; |