view release on metacpan or  search on metacpan

t/lib/TestHelper.pm  view on Meta::CPAN

            run_subtest("$check_flag_label location($from_line)", $subtest);
        }
    };
    push @TEST_QUEUE, $test;
}

sub ok_location {
    _test_location(\$IS_STOPPED, 'stopped', @_);
}

sub ok_trace_location {
    _test_location(\$IS_TRACE, 'traced', @_);
}

sub ok_uncaught_exception {
    _test_location(\$IS_EXCEPTION, 'stopped in exception', @_);
}

sub ok_watched_expr_notification {
    my %params = @_;

    unless (exists $params{expr} and exists $params{old} and exists $params{new}) {
        die "'expr', 'old' and 'new' are required args to ok_watched_expr";
    }
    my $expected_expr = delete $params{expr};
    my $expected_old = delete $params{old};
    my $expected_new = delete $params{new};

    push @TEST_QUEUE, sub {
        my($location, $expr, $old, $new) = @_;
        run_subtest("notifying changed expr $expected_expr", sub {
            unless ($IS_WATCH_NOTIFICATION) {
                fail('Cheching for watched expr change when no notification was received');
                return;
            }
            _test_location_contents($location, %params);
            is($expr, $expected_expr, 'expr');
            is($old, $expected_old, 'old value');
            is($new, $expected_new, 'new value');
        });
    };
}

sub ok_subroutine_location {
    my($subname, %params) = @_;
    push @TEST_QUEUE, sub {
        my $sublocation = __PACKAGE__->subroutine_location($subname);
        my $subtest = sub {
            _test_location_contents($sublocation, %params);
        };

        context_do {
            run_subtest("subroutine_location for $subname", $subtest);
        };
    };
}

sub ok_breakpoint {
    my %params = @_;

    my($file, $from_line) = (caller)[1, 2];
    $params{file} = $file unless exists ($params{file});
    my $bp_line = $params{line};

    my $subtest = sub {
        my @bp = Devel::Chitin::Breakpoint->get(%params);
        if (@bp != 1) {
            fail("Expected 1 breakpoint in ok_breakpoint($from_line), but got ".scalar(@bp));
        }

        ok($bp[0], 'Got breakpoint');
        foreach my $attr ( keys %params ) {
            is($bp[0]->$attr, $params{$attr}, $attr);
        }
    };
    push @TEST_QUEUE, sub {
        context_do {
            run_subtest("breakpoint($from_line) ${file}:${bp_line}", $subtest);
        }
    };
}

sub ok_at_end {
    my $from_line = (caller)[2];

    my $test = sub {
        context_do {
            my $ctx = shift;
            $ctx->ok($AT_END, "at_end($from_line)");
        };

        __PACKAGE__->disable_debugger if (! @TEST_QUEUE and $AT_END);
    };
    push @TEST_QUEUE, $test;
}

sub ok_breakable {
    my($file, $line) = @_;
    my $from_line = (caller)[2];

    my $test = sub {
        context_do {
            my $ctx = shift;
            $ctx->ok( __PACKAGE__->is_breakable($file, $line), "${file}:${line} is breakable");
        };
    };
    push @TEST_QUEUE, $test;
}

sub ok_not_breakable {
    my($file, $line) = @_;

    my $test = sub {
        context_do {
            my $ctx = shift;
            $ctx->ok( ! __PACKAGE__->is_breakable($file, $line), "${file}:${line} is not breakable");
        };
    };
    push @TEST_QUEUE, $test;
}

sub ok_add_watchexpr {
    my($expr, $comment) = @_;

    my $test = sub {
        context_do {
            my $ctx = shift;
            $ctx->ok( __PACKAGE__->add_watchexpr($expr), $comment);
        };
    };
    push @TEST_QUEUE, $test;
}

sub ok_set_action {
    my $comment = pop;
    my %params = @_;

    $params{file} = (caller)[1] unless exists $params{file};

    my $test = sub {
        context_do {
            my $ctx = shift;
            $ctx->ok( Devel::Chitin::Action->new(%params), $comment);
        };
    };
    push @TEST_QUEUE, $test;
}

sub ok_set_breakpoint {
    my $comment = pop;
    my %params = @_;

    $params{file} = (caller)[1] unless exists $params{file};

    my $test = sub {
        context_do {
            my $ctx = shift;
            $ctx->ok( Devel::Chitin::Breakpoint->new(%params), $comment);
        };
    };
    push @TEST_QUEUE, $test;
}

sub ok_change_breakpoint {
    my $comment = pop;
    my %params = @_;

    my $changes = delete $params{change};
    unless (ref($changes) eq 'HASH') {
        Carp::croak("'change' is a required param to ok_change_breakpoint(), and must be a hashref");
    }

    my $test = sub {
        context_do {
            my $ctx = shift;

            my @bp = Devel::Chitin::Breakpoint->get(%params);
            unless (@bp) {
                $ctx->fail('params matched no breakpoints: ', join(', ', map { "$_ => ".$params{$_} } keys(%params)));
            }
            foreach my $bp ( @bp ) {
                foreach my $param (keys %$changes) {
                    $bp->$param($changes->{$param});
                }
                $ctx->pass(sprintf('%s at %s:%d', $comment, $bp->file, $bp->line));
            }
        };
    };
    push @TEST_QUEUE, $test;
}

sub ok_delete_breakpoint {
    my $comment = pop;
    my %params = @_;

    my $test = sub {
        context_do {
            my $ctx = shift;

            my @bp = Devel::Chitin::Breakpoint->get(%params);
            foreach my $bp ( @bp ) {
                $ctx->ok($bp->delete, sprintf('Delete breakpoint at %s:%d', $bp->file, $bp->line));
            }
        };
    };
    push @TEST_QUEUE, $test;
}

sub do_test(&) {
    push @TEST_QUEUE, shift();
}

sub is_var_at_level {