File Coverage

blib/lib/Devel/Caller/Util.pm

Criterion	Covered	Total	%
statement	33	41	80.4
branch	15	28	53.5
condition	2	3	66.6
subroutine	5	5	100.0
pod	2	2	100.0
total	57	79	72.1

package Devel::Caller::Util;

our $DATE = '2019-04-12'; # DATE
our $VERSION = '0.042'; # VERSION

use warnings;
use strict;

use Exporter qw(import);
our @EXPORT_OK = qw(caller callers);

my $_is_caller;

sub callers {
    my ($start, $with_args, $packages_to_ignore, $subroutines_to_ignore) = @_;
    $start = 0 unless defined $start;

    my @res;
    my $i = 1;

    while (1) {
        my @caller;
        if ($with_args) {
            {
                package # hide from PAUSE
                    DB;
                @caller = caller($i);
                $caller[11] = [@DB::args] if @caller;
            }
        } else {
            @caller = caller($i);
        }
        last unless @caller;
        $i++;

        if ($packages_to_ignore) {
            if (ref $packages_to_ignore eq 'ARRAY') {
                next if grep { $_ eq $caller[0] } @$packages_to_ignore;
            } else {
                next if $caller[0] =~ $packages_to_ignore;
            }
        }

        if ($subroutines_to_ignore) {
            if (ref $subroutines_to_ignore eq 'ARRAY') {
                next if grep { $_ eq $caller[3] } @$subroutines_to_ignore;
            } else {
                next if $caller[3] =~ $subroutines_to_ignore;
            }
        }

        push @res, \@caller;
        do { $_is_caller = 0; return @caller } if $_is_caller && @res == $start+1;
    }

    splice @res, 0, $start if $start;
    $_is_caller = 0;
    @res;
}

sub caller {
    $_is_caller = 1; # "local" doesn't work here
    goto &callers;
}

1;
# ABSTRACT: caller()-related utility routines

__END__