Commit | Line | Data |
c0329273 |
1 | BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } |
2 | |
7cb35852 |
3 | use strict; |
4 | use warnings; |
5 | |
c0329273 |
6 | |
7cb35852 |
7 | use DBICTest::RunMode; |
8 | BEGIN { |
9 | if( DBICTest::RunMode->is_plain ) { |
10 | print "1..0 # SKIP not running dangerous segfault-prone test on plain install\n"; |
11 | exit 0; |
12 | } |
13 | } |
14 | |
20c0d57b |
15 | use DBICTest::Util 'capture_stderr'; |
7cb35852 |
16 | use DBIx::Class::Schema; |
17 | |
18 | # Do not use T::B - the test is hard enough not to segfault as it is |
19 | my $test_count = 0; |
20 | |
21 | # start with one failure, and decrement it at the end |
22 | my $failed = 1; |
23 | |
24 | sub ok { |
25 | printf STDOUT ("%s %u - %s\n", |
26 | ( $_[0] ? 'ok' : 'not ok' ), |
27 | ++$test_count, |
28 | $_[1] || '', |
29 | ); |
30 | |
31 | unless( $_[0] ) { |
32 | $failed++; |
33 | printf STDERR ("# Failed test #%d at %s line %d\n", |
34 | $test_count, |
35 | (caller(0))[1,2] |
36 | ); |
37 | } |
38 | |
39 | return !!$_[0]; |
40 | } |
41 | |
7cb35852 |
42 | # this is incredibly horrible... |
43 | # demonstrate utter breakage of the reconnection/retry logic |
44 | # |
20c0d57b |
45 | my $output = capture_stderr { |
7cb35852 |
46 | ESCAPE: |
47 | { |
20c0d57b |
48 | # yes, make it even dirtier |
49 | my $schema = 'DBIx::Class::Schema'; |
7cb35852 |
50 | |
20c0d57b |
51 | $schema->connection('dbi:SQLite::memory:'); |
7cb35852 |
52 | $schema->storage->ensure_connected; |
53 | $schema->storage->_dbh->disconnect; |
54 | |
c40b5744 |
55 | # silences "exitting sub via last" |
7cb35852 |
56 | local $SIG{__WARN__} = sub {}; |
57 | |
58 | $schema->exception_action(sub { |
59 | ok(1, 'exception_action invoked'); |
60 | # essentially what Dancer2's redirect() does after https://github.com/PerlDancer/Dancer2/pull/485 |
61 | # which "nicely" combines with: https://metacpan.org/source/MARKOV/Log-Report-1.12/lib/Dancer2/Plugin/LogReport.pm#L143 |
62 | # as encouraged by: https://metacpan.org/pod/release/MARKOV/Log-Report-1.12/lib/Dancer2/Plugin/LogReport.pod#Logging-DBIC-database-queries-and-errors |
63 | last ESCAPE; |
64 | }); |
65 | |
66 | # this *DOES* throw, but the exception will *NEVER SHOW UP* |
67 | $schema->storage->dbh_do(sub { $_[1]->selectall_arrayref("SELECT * FROM wfwqfdqefqef") } ); |
68 | |
69 | # NEITHER will this |
70 | ok(0, "Nope"); |
20c0d57b |
71 | }}; |
7cb35852 |
72 | |
73 | ok(1, "Post-escape reached"); |
74 | |
75 | ok( |
76 | !!( $output =~ /DBIx::Class INTERNAL PANIC.+FIX YOUR ERROR HANDLING/s ), |
77 | 'Proper warning emitted on STDERR' |
78 | ) or print STDERR "Instead found:\n\n$output\n"; |
79 | |
80 | print "1..$test_count\n"; |
81 | |
82 | # this is our "done_testing" |
83 | $failed--; |
84 | |
85 | # avoid tasty segfaults on 5.8.x |
86 | exit( $failed ); |