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