diff --git a/Changes b/Changes index 79cb62ea..418e74ab 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,7 @@ {{$NEXT}} + - Add Test2::Plugin::DebugOnFail + 0.000153 2023-04-27 15:27:32-07:00 America/Los_Angeles - Fix broken call to plugins diff --git a/lib/Test2/Plugin/DebugOnFail.pm b/lib/Test2/Plugin/DebugOnFail.pm new file mode 100644 index 00000000..51289580 --- /dev/null +++ b/lib/Test2/Plugin/DebugOnFail.pm @@ -0,0 +1,84 @@ +package Test2::Plugin::DebugOnFail; +use strict; +use warnings; + +our $VERSION = '0.000154'; + +use Test2::API qw{ + test2_add_callback_post_load + test2_stack +}; + +sub import { + my $class = shift; + + test2_add_callback_post_load(sub { + my $hub = test2_stack()->top; + + $hub->pre_filter( + sub { + my ($hub, $event) = @_; + + if ($event->causes_fail) { + warn "Test failure detected, stopping debugger...\n"; + $DB::single = 1; + } + + return $event; + }, + inherit => 1, + ); + }); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Plugin::DebugOnFail - Set "$DB::single = 1" on test failure. + +=head1 DESCRIPTION + +This will set C<$DB::single = 1> on any failure in the test suite. + +=head1 SYNOPSIS + + use Test2::Plugin::DebugOnFail; + +=head1 SOURCE + +The source code repository for Test2-Suite can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/t/modules/Plugin/DebugOnFail.t b/t/modules/Plugin/DebugOnFail.t new file mode 100644 index 00000000..00784ce7 --- /dev/null +++ b/t/modules/Plugin/DebugOnFail.t @@ -0,0 +1,23 @@ +use Test2::V0; +use Test2::API qw/intercept/; + +my ($start, $second, $third); +my $events = intercept { + require Test2::Plugin::DebugOnFail; + Test2::Plugin::DebugOnFail->import; + + my $warn; + local $SIG{__WARN__} = sub { ($warn) = @_ }; + + $start = $warn; + ok(1); + $second = $warn; + ok(0); + $third = $warn; +}; + +is($start, undef, "Not set initially"); +is($second, undef, "Not set after pass"); +is($third, "Test failure detected, stopping debugger...\n", "Is set after pass"); + +done_testing;