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