The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl
use strict;
use warnings;
use Devel::Backtrace;
use Test::More tests => 8;

Foo::foo1();

{
    package Foo;

    sub foo1 {
        foo2();
    }

    sub foo2 {
        Bar::bar1();
    }
}

{
    package Bar;

    sub bar1 {
        bar2();
    }

    sub bar2 {
        Baz::baz1();
    }
}

{
    package Baz;

    sub baz1 {
        baz2();
    }

    sub baz2 {
        baz3();
    }

    sub baz3 {
        my $backtrace = Devel::Backtrace->new;

        warn "pure backtrace: $backtrace" if $ENV{DEBUG};

        # Tell Devel::Backtrace that we are not interested in what Baz method
        # calls which Baz method.
        $backtrace->skipme;

        warn "backtrace: $backtrace" if $ENV{DEBUG};

        use Test::More;

        is(scalar($backtrace->points), 5, 'skipme count')
            or warn "skipme count: $backtrace";
        is($backtrace->point(0)->subroutine, 'Baz::baz1', 'skipme')
            or warn "skipme: $backtrace";

        my $backtrace2 = Devel::Backtrace->new;

        # Tell Devel::Backtrace that we are not even interested where the first
        # Baz method was called.
        $backtrace2->skipmysubs;

        is (scalar($backtrace2->points), 4, 'skipmysubs count')
            or warn "skipmysubs count: $backtrace";
        is ($backtrace2->point(0)->subroutine, 'Bar::bar2', 'skipmysubs')
            or warn "skipmysubs: $backtrace";

        warn "backtrace2: $backtrace2" if $ENV{DEBUG};

        my $backtrace3 = Devel::Backtrace->new(1);
        $backtrace3->skipmysubs('Baz');

        warn "backtrace3: $backtrace3" if $ENV{DEBUG};

        is ($backtrace3->point(1)->to_string(-format => '%I'), 1, '%I')
            or warn "%I: $backtrace3";
        is ($backtrace3->point(1)->_skip, 4, '_skip')
            or warn "_skip: $backtrace3";
        is ($backtrace3->point(1)->to_string(-format => '%i'), 5, '%i')
            or warn "%i: $backtrace3";

        # Same as above, but use -start instead of plain argument to new.
        my $backtrace4 = Devel::Backtrace->new(-start => 1);
        $backtrace4->skipmysubs('Baz');
        is ($backtrace4->point(1)->_skip, 4, '_skip / -start')
            or warn "_skip / -start: $backtrace3 --\n$backtrace4";
    }
}