use 5.010;
use strict;
use warnings;

package DB::Pluggable::Plugin::BreakOnTestNumber;
BEGIN {
  $DB::Pluggable::Plugin::BreakOnTestNumber::VERSION = '1.111751';
}

# ABSTRACT: Debugger plugin to break on Test::Builder-based tests
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
);

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__
=pod

=for stopwords watchfunction

=for test_synopsis 1;
__END__

=head1 NAME

DB::Pluggable::Plugin::BreakOnTestNumber - Debugger plugin to break on Test::Builder-based tests

=head1 VERSION

version 1.111751

=head1 SYNOPSIS

    $ cat ~/.perldb

    use DB::Pluggable;
    DB::Pluggable->run_with_config(\<<EOINI)
    [BreakOnTestNumber]
    EOINI

    $ perl -d foo.pl

    Loading DB routines from perl5db.pl version 1.28
    Editor support available.

    Enter h or `h h' for help, or `man perldebug' for more help.

    1..9
    ...
      DB<1> b #5
      DB<2> r

=head1 DESCRIPTION

This debugger plugin extends the debugger's C<b> command - used to set
breakpoints - with the ability to stop at a specific test number. Andy
Armstrong had the idea and wrote the original code, see
L<http://use.perl.org/~AndyArmstrong/journal/35792>.

=head1 METHODS

=head2 initialize

Sets up the command handler that checks whether the command is of
the form C<b #12> or C<b #12, 34, ...>. If so, it sets breakpoints
to break as soon as the given test has finished. If test-based
breakpoints have been found, the standard C<DB::cmd_b()> function that
handles the C<b> command is short-circuited.

If it handles the command, it enables the C<watchfunction()>.

This plugin overwrites C<Test::Builder::lock()> to be able to
detect that a test is about to be finished - see the source code of
L<Test::Builder> for details. Yes, this is nasty. It also means that
this plugin will break C<Test::Builder> when using threads.

=head2 watchfunction

Checks the current test number from L<Test::Builder> and instructs the
debugger to stop if an appropriate test number has been reached.

=head1 INSTALLATION

See perlmodinstall for information and options on installing Perl modules.

=head1 BUGS AND LIMITATIONS

No bugs have been reported.

Please report any bugs or feature requests through the web interface at
L<http://rt.cpan.org/Public/Dist/Display.html?Name=DB-Pluggable>.

=head1 AVAILABILITY

The latest version of this module is available from the Comprehensive Perl
Archive Network (CPAN). Visit L<http://www.perl.com/CPAN/> to find a CPAN
site near you, or see L<http://search.cpan.org/dist/DB-Pluggable/>.

The development version lives at L<http://github.com/hanekomu/DB-Pluggable>
and may be cloned from L<git://github.com/hanekomu/DB-Pluggable.git>.
Instead of sending patches, please fork this project using the standard
git and github infrastructure.

=head1 AUTHOR

Marcel Gruenauer <marcel@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2008 by Marcel Gruenauer.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

