File Coverage

blib/lib/DB/Pluggable/Plugin/BreakOnTestNumber.pm

Criterion	Covered	Total	%
statement	26	52	50.0
branch	0	12	0.0
condition	0	3	0.0
subroutine	9	12	75.0
pod	2	2	100.0
total	37	81	45.6

package DB::Pluggable::Plugin::BreakOnTestNumber;
use strict;
use warnings;
use 5.010;
use Role::Basic;
use Hook::LexWrap;
use Test::Builder;    # preload so we can "safely" overwrite lock()
with qw(
  DB::Pluggable::Role::Initializer
  DB::Pluggable::Role::WatchFunction
);
our $VERSION = '1.12';

sub initialize {
    @DB::testbreak = ();
    our $cmd_b_wrapper = wrap 'DB::cmd_b', pre => sub {
        return unless $_[1] =~ /\s*#\s*(\d+(?:\s*,\s*\d+)*)$/;
        my %seen;
        @DB::testbreak = grep { !$seen{$_}++ }
          sort { $a <=> $b } (split(/\s*,\s*/, $1), @DB::testbreak);

        # Making use of the fact that Test::Builder calls lock() each
        # time before accessing {Curr_Test} is a hack, but directly
        # enabling the watchfunction here would mean everything slows
        # down to a crawl. It also means that this plugin won't work
        # with threads. And let's hope Test::Builder continues to use
        # lock()... Not nice, but it works and is fast.
        no warnings 'redefine';
        no strict 'refs';
        *Test::Builder::lock = sub {
            return if (caller(1))[3] eq 'Test::Builder::current_test';

            # Enable watchfunction
            $DB::trace |= 4;
        };

        # short-circuit (i.e., don't call the original debugger function)
        # if a plugin has handled it
        $_[-1] = 1;
        return;
      }
}

sub watchfunction {
    my $self = shift;

    # disable the watchfunction until it is next enabled by lock()
    $DB::trace &= ~4;
    return unless @DB::testbreak;
    my $next = Test::Builder->new->current_test + 1;
    if ($next >= $DB::testbreak[0]) {
        shift @DB::testbreak while @DB::testbreak && $next >= $DB::testbreak[0];
        my $depth = 1;
        while (1) {
            my $package = (caller $depth)[0];
            last unless defined $package;
            last unless $package =~ /^(DB(::|$)|Test::)/;
            $depth++;
        }
        no warnings 'once';
        $DB::stack[ -$depth + 1 ] = 1;
    }
    return;
}
1;

__END__