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 | |
15 | use File::Temp (); |
16 | use DBIx::Class::_Util 'scope_guard'; |
17 | use DBIx::Class::Schema; |
18 | |
19 | # Do not use T::B - the test is hard enough not to segfault as it is |
20 | my $test_count = 0; |
21 | |
22 | # start with one failure, and decrement it at the end |
23 | my $failed = 1; |
24 | |
25 | sub ok { |
26 | printf STDOUT ("%s %u - %s\n", |
27 | ( $_[0] ? 'ok' : 'not ok' ), |
28 | ++$test_count, |
29 | $_[1] || '', |
30 | ); |
31 | |
32 | unless( $_[0] ) { |
33 | $failed++; |
34 | printf STDERR ("# Failed test #%d at %s line %d\n", |
35 | $test_count, |
36 | (caller(0))[1,2] |
37 | ); |
38 | } |
39 | |
40 | return !!$_[0]; |
41 | } |
42 | |
43 | # yes, make it even dirtier |
44 | my $schema = 'DBIx::Class::Schema'; |
45 | |
46 | $schema->connection('dbi:SQLite::memory:'); |
47 | |
48 | # this is incredibly horrible... |
49 | # demonstrate utter breakage of the reconnection/retry logic |
50 | # |
51 | open(my $stderr_copy, '>&', *STDERR) or die "Unable to dup STDERR: $!"; |
52 | my $tf = File::Temp->new( UNLINK => 1 ); |
53 | |
54 | my $output; |
55 | |
56 | ESCAPE: |
57 | { |
58 | my $guard = scope_guard { |
59 | close STDERR; |
60 | open(STDERR, '>&', $stderr_copy); |
61 | $output = do { local (@ARGV, $/) = $tf; <> }; |
62 | close $tf; |
63 | unlink $tf; |
64 | undef $tf; |
65 | close $stderr_copy; |
66 | }; |
67 | |
68 | close STDERR; |
69 | open(STDERR, '>&', $tf) or die "Unable to reopen STDERR: $!"; |
70 | |
71 | $schema->storage->ensure_connected; |
72 | $schema->storage->_dbh->disconnect; |
73 | |
74 | local $SIG{__WARN__} = sub {}; |
75 | |
76 | $schema->exception_action(sub { |
77 | ok(1, 'exception_action invoked'); |
78 | # essentially what Dancer2's redirect() does after https://github.com/PerlDancer/Dancer2/pull/485 |
79 | # which "nicely" combines with: https://metacpan.org/source/MARKOV/Log-Report-1.12/lib/Dancer2/Plugin/LogReport.pm#L143 |
80 | # as encouraged by: https://metacpan.org/pod/release/MARKOV/Log-Report-1.12/lib/Dancer2/Plugin/LogReport.pod#Logging-DBIC-database-queries-and-errors |
81 | last ESCAPE; |
82 | }); |
83 | |
84 | # this *DOES* throw, but the exception will *NEVER SHOW UP* |
85 | $schema->storage->dbh_do(sub { $_[1]->selectall_arrayref("SELECT * FROM wfwqfdqefqef") } ); |
86 | |
87 | # NEITHER will this |
88 | ok(0, "Nope"); |
89 | } |
90 | |
91 | ok(1, "Post-escape reached"); |
92 | |
93 | ok( |
94 | !!( $output =~ /DBIx::Class INTERNAL PANIC.+FIX YOUR ERROR HANDLING/s ), |
95 | 'Proper warning emitted on STDERR' |
96 | ) or print STDERR "Instead found:\n\n$output\n"; |
97 | |
98 | print "1..$test_count\n"; |
99 | |
100 | # this is our "done_testing" |
101 | $failed--; |
102 | |
103 | # avoid tasty segfaults on 5.8.x |
104 | exit( $failed ); |