Is it possible to make Test::more report the line of an indirect caller (level-n caller)?

Question

I wrote some test framework using Perl's Test::more, specifically using the ok($test_result, $test_description). As some tests "cluster", I wrote a subroutine that performs multiple ok() tests, and the main program calls such subroutines.

Now the problem for a failed test is this: Test::More outputs the line number within the subroutine (direct caller), but I'd like to have the "caller's caller" (indirect caller) line to be output instead.

Is that possible?

Imagine the code to be similar as this:

#!/usr/bin/perl
use 5.18.2;
use warnings;
use strict;
use Test::More;

sub foo(@)
{
    # do something magical
    return undef;
}

sub foo_OK(@)
{
    ok(foo(@_), 'foo_OK: ' . join(' ', @_)); # actually less trivial
}

sub complex_test(@)
{
    foo_OK(qw(something special), @_);
    foo_OK(qw(something else), @_);
    #...

}

sub main()
{
    complex_test(qw(abra kadabra));
    complex_test(qw(more magic));
    #...
}

main();
done_testing();

So I'd like to see the line of main, not the line of test_OK if ok() fails. As shown the output would be:

not ok 1 - foo_OK: something special abra kadabra
#   Failed test 'foo_OK: something special abra kadabra'
#   at /tmp/test.pl line 15.
not ok 2 - foo_OK: something else abra kadabra
#   Failed test 'foo_OK: something else abra kadabra'
#   at /tmp/test.pl line 15.
not ok 3 - foo_OK: something special more magic
#   Failed test 'foo_OK: something special more magic'
#   at /tmp/test.pl line 15.
not ok 4 - foo_OK: something else more magic
#   Failed test 'foo_OK: something else more magic'
#   at /tmp/test.pl line 15.
1..4
# Looks like you failed 4 tests of 4.

Answer 1

Test::More uses Test::Builder under the hood. You can modify Test::Builder's idea of how far up the stack to go by modifying a localized copy of $Test::Builder::Level. So:

# Emulate Test2::V0::is(), kinda sorta
sub my_is {
    my ( $got, $want, $name ) = @_;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    if ( ref $want ) {
        return is_deeply( $got, $want, $name );
    } else {
        return is( $got, $want, $name );
    }
}

Caveat: if you get fancy with your call tree it can be difficult to get the number of levels right.

Answer 2

Based on https://stackoverflow.com/a/78083924/6607497 I used Test::Builder to create sub-tests via the child() method, so a failing test would show the line number, but also causing the parent test to fail (that would also print the line number). That way I get the information I wanted, even with more output that ideally wanted.

A modified example would look like this (line numbers added to understand the output better):

  1:#!/usr/bin/perl
  2:use 5.18.2;
  3:use warnings;
  4:use strict;
  5:
  6:use Test::Builder;
  7:
  8:sub foo($$$)
  9:{
 10:    my ($TB, $test, $desc) = @_;
 11:
 12:    $TB->plan('tests' => 1);
 13:    $test = int(rand() * 2);        # simulate random failure
 14:    $TB->ok($test, $desc);
 15:    $TB->finalize();
 16:}
 17:
 18:sub bar($$$)
 19:{
 20:    my ($TB, $test, $desc) = @_;
 21:
 22:    $TB->plan('tests' => 1);
 23:    $test = int(rand() * 2);        # simulate random failure
 24:    $TB->ok($test, $desc);
 25:    $TB->finalize();
 26:}
 27:
 28:sub foo_bar($$$)
 29:{
 30:    my ($TB, $test, $desc) = @_;
 31:    my $subtest = sub($) { $TB->diag($_[0]); return $TB->child($_[0]); };
 32:
 33:    $TB->plan('tests' => 2);
 34:    foo($subtest->('foo'), $test, $desc . ' foo_bar foo-param');
 35:    bar($subtest->('bar'), $test, $desc . ' foo_bar bar-param');
 36:    $TB->finalize();
 37:}
 38:
 39:sub complex_test($$$)
 40:{
 41:    my ($TB, $test, $desc) = @_;
 42:    my $subtest = sub($) { $TB->diag($_[0]); return $TB->child($_[0]); };
 43:
 44:    $TB->plan('tests' => 3);
 45:    foo($subtest->('foo'), $test, $desc . ' complex_test foo-param');
 46:    bar($subtest->('bar'), $test, $desc . ' complex_test bar-param');
 47:    foo_bar($subtest->('foobar'), $test, $desc . ' complex_test foo_bar-param');
 48:    $TB->finalize();
 49:}
 50:
 51:sub main()
 52:{
 53:    my $TB = Test::Builder->create();
 54:    my $subtest = sub($) { $TB->diag($_[0]); return $TB->child($_[0]); };
 55:
 56:    $TB->plan('tests' => 2);
 57:    complex_test($subtest->('sub1'), 0, q(abra kadabra));
 58:    complex_test($subtest->('sub2'), 0, q(more magic));
 59:    #...
 60:    $TB->done_testing();
 61:}
 62:
 63:main();

And an example output would be:

1..2
# sub1
    1..3
    # foo
        1..1
        ok 1 - abra kadabra complex_test foo-param
    ok 1 - foo
    # bar
        1..1
        ok 1 - abra kadabra complex_test bar-param
    ok 2 - bar
    # foobar
        1..2
        # foo
            1..1
            ok 1 - abra kadabra complex_test foo_bar-param foo_bar foo-param
        ok 1 - foo
        # bar
            1..1
            ok 1 - abra kadabra complex_test foo_bar-param foo_bar bar-param
        ok 2 - bar
    ok 3 - foobar
ok 1 - sub1
# sub2
    1..3
    # foo
        1..1
        ok 1 - more magic complex_test foo-param
    ok 1 - foo
    # bar
        1..1
        not ok 1 - more magic complex_test bar-param
        #   Failed test 'more magic complex_test bar-param'
        #   at /tmp/test.pl line 46.
        # Looks like you failed 1 test of 1.
    not ok 2 - bar
    #   Failed test 'bar'
    #   at /tmp/test.pl line 46.
    # foobar
        1..2
        # foo
            1..1
            not ok 1 - more magic complex_test foo_bar-param foo_bar foo-param
            #   Failed test 'more magic complex_test foo_bar-param foo_bar foo-param'
            #   at /tmp/test.pl line 34.
            # Looks like you failed 1 test of 1.
        not ok 1 - foo
        #   Failed test 'foo'
        #   at /tmp/test.pl line 34.
        # bar
            1..1
            not ok 1 - more magic complex_test foo_bar-param foo_bar bar-param
            #   Failed test 'more magic complex_test foo_bar-param foo_bar bar-param'
            #   at /tmp/test.pl line 35.
            # Looks like you failed 1 test of 1.
        not ok 2 - bar
        #   Failed test 'bar'
        #   at /tmp/test.pl line 35.
        # Looks like you failed 2 tests of 2.
    not ok 3 - foobar
    #   Failed test 'foobar'
    #   at /tmp/test.pl line 47.
    # Looks like you failed 2 tests of 3.
not ok 2 - sub2
#   Failed test 'sub2'
#   at /tmp/test.pl line 58.

Answer 3

If you want to create new test functions, use Test::Builder. It knows how to handle these things. You can look at any of my Test:: modules as an example (perhaps Test::File).

In Perl v5.26 and later, you can (maybe should) do the same with Test2::API, although Test::Builder still works.

Answer 4

This problem indicates that you are using subpar test names.

---

But in this case, you can replace

sub foo_OK(@)
{
    ok(foo(@_), 'foo_OK: ' . join(' ', @_));
}

with

sub foo_OK(@)
{
    @_ = (foo(@_), 'foo_OK: ' . join(' ', @_));
    goto &ok;
}

Answer 5

I came up with this somewhat ugly solution (with slightly modified tests), manually adding a trace-back (line-numbers added for ease of understanding the output):

 1:#!/usr/bin/perl
 2:use 5.18.2;
 3:use warnings;
 4:use strict;
 5:
 6:use Test::More;
 7:
 8:sub backtrace($)
 9:{
10:    my @labels = @{$_[0]}; print join('|', @labels), "\n";
11:    my $label;
12:
13:    $_ = 0;
14:    while (my ($file, $line, $name) = (caller($_))[1, 2, 3]) {
15:        last if ($#labels < 0);
16:        $label = pop(@labels) // '...';
17:        diag("($_) $label called from $file line $line\n");
18:        ++$_;
19:    }
20:}
21:
22:sub foo($$$)
23:{
24:    my ($labels, $test, $desc) = @_;
25:
26:    $labels = [@$labels, 'foo'];
27:    backtrace([@$labels, $desc]) unless (ok($test, $desc));
28:}
29:
30:sub bar($$$)
31:{
32:    my ($labels, $test, $desc) = @_;
33:
34:    $labels = [@$labels, 'bar'];
35:    backtrace([@$labels, $desc]) unless (ok($test, $desc));
36:}
37:
38:sub foo_bar($$$)
39:{
40:    my ($labels, $test, $desc) = @_;
41:
42:    $labels = [@$labels, 'foo_bar'];
43:    backtrace([@$labels, 'foo1']) unless (foo($labels, $test, 'foo-param'));
44:    backtrace([@$labels, 'bar1']) unless (foo($labels, $test, 'bar-param'));
45:}
46:
47:sub complex_test($$$)
48:{
49:    my ($labels, $test, $desc) = @_;
50:
51:    $labels = [@$labels, 'complex_test'];
52:    backtrace([@$labels, 'foo1']) unless (foo($labels, $test, 'foo-param'));
53:    backtrace([@$labels, 'bar1']) unless (bar($labels, $test, 'bar-param'));
54:    backtrace([@$labels, 'foo_bar1']) unless (foo_bar($labels, $test, 'foo_bar-param'));
55:}
56:
57:sub main()
58:{
59:    complex_test([], 0, q(abra kadabra));
60:    complex_test([], 0, q(more magic));
61:    #...
62:}
63:
64:main();
65:done_testing();

not ok 1 - foo-param
#   Failed test 'foo-param'
#   at /tmp/test.pl line 27.
complex_test|foo|foo-param
# (0) foo-param called from /tmp/test.pl line 27
# (1) foo called from /tmp/test.pl line 52
# (2) complex_test called from /tmp/test.pl line 59
complex_test|foo1
# (0) foo1 called from /tmp/test.pl line 52
# (1) complex_test called from /tmp/test.pl line 59
not ok 2 - bar-param
#   Failed test 'bar-param'
#   at /tmp/test.pl line 35.
complex_test|bar|bar-param
# (0) bar-param called from /tmp/test.pl line 35
# (1) bar called from /tmp/test.pl line 53
# (2) complex_test called from /tmp/test.pl line 59
complex_test|bar1
# (0) bar1 called from /tmp/test.pl line 53
# (1) complex_test called from /tmp/test.pl line 59
not ok 3 - foo-param
#   Failed test 'foo-param'
#   at /tmp/test.pl line 27.
complex_test|foo_bar|foo|foo-param
# (0) foo-param called from /tmp/test.pl line 27
# (1) foo called from /tmp/test.pl line 43
# (2) foo_bar called from /tmp/test.pl line 54
# (3) complex_test called from /tmp/test.pl line 59
complex_test|foo_bar|foo1
# (0) foo1 called from /tmp/test.pl line 43
# (1) foo_bar called from /tmp/test.pl line 54
# (2) complex_test called from /tmp/test.pl line 59
not ok 4 - bar-param
#   Failed test 'bar-param'
#   at /tmp/test.pl line 27.
complex_test|foo_bar|foo|bar-param
# (0) bar-param called from /tmp/test.pl line 27
# (1) foo called from /tmp/test.pl line 44
# (2) foo_bar called from /tmp/test.pl line 54
# (3) complex_test called from /tmp/test.pl line 59
complex_test|foo_bar|bar1
# (0) bar1 called from /tmp/test.pl line 44
# (1) foo_bar called from /tmp/test.pl line 54
# (2) complex_test called from /tmp/test.pl line 59
complex_test|foo_bar1
# (0) foo_bar1 called from /tmp/test.pl line 54
# (1) complex_test called from /tmp/test.pl line 59
not ok 5 - foo-param
#   Failed test 'foo-param'
#   at /tmp/test.pl line 27.
complex_test|foo|foo-param
# (0) foo-param called from /tmp/test.pl line 27
# (1) foo called from /tmp/test.pl line 52
# (2) complex_test called from /tmp/test.pl line 60
complex_test|foo1
# (0) foo1 called from /tmp/test.pl line 52
# (1) complex_test called from /tmp/test.pl line 60
not ok 6 - bar-param
#   Failed test 'bar-param'
#   at /tmp/test.pl line 35.
complex_test|bar|bar-param
# (0) bar-param called from /tmp/test.pl line 35
# (1) bar called from /tmp/test.pl line 53
# (2) complex_test called from /tmp/test.pl line 60
complex_test|bar1
# (0) bar1 called from /tmp/test.pl line 53
# (1) complex_test called from /tmp/test.pl line 60
not ok 7 - foo-param
#   Failed test 'foo-param'
#   at /tmp/test.pl line 27.
complex_test|foo_bar|foo|foo-param
# (0) foo-param called from /tmp/test.pl line 27
# (1) foo called from /tmp/test.pl line 43
# (2) foo_bar called from /tmp/test.pl line 54
# (3) complex_test called from /tmp/test.pl line 60
complex_test|foo_bar|foo1
# (0) foo1 called from /tmp/test.pl line 43
# (1) foo_bar called from /tmp/test.pl line 54
# (2) complex_test called from /tmp/test.pl line 60
not ok 8 - bar-param
#   Failed test 'bar-param'
#   at /tmp/test.pl line 27.
complex_test|foo_bar|foo|bar-param
# (0) bar-param called from /tmp/test.pl line 27
# (1) foo called from /tmp/test.pl line 44
# (2) foo_bar called from /tmp/test.pl line 54
# (3) complex_test called from /tmp/test.pl line 60
complex_test|foo_bar|bar1
# (0) bar1 called from /tmp/test.pl line 44
# (1) foo_bar called from /tmp/test.pl line 54
# (2) complex_test called from /tmp/test.pl line 60
complex_test|foo_bar1
# (0) foo_bar1 called from /tmp/test.pl line 54
# (1) complex_test called from /tmp/test.pl line 60
1..8
# Looks like you failed 8 tests of 8.

Note: I forgot the debug-left-over print join('|', @labels), "\n";- so please remove that and ignore the corresponding output!

Answer 6

Test::More doesn't support this feature. I was looking at the Test::More source code, and I've found this:

my($pack, $file, $line) = $self->caller;
...
$result->{fail_diag} = ("    $msg test ($file at line $line)\n");

Maybe I was looking at the wrong part. To be 100% sure, you can temporary modify the line (e.g. change $msg to ZZZ$msg test), and see if you get the modified message.