File Coverage

blib/lib/Devel/CallerStack.pm

Criterion	Covered	Total	%
statement	99	101	98.0
branch	20	24	83.3
condition	4	5	80.0
subroutine	28	28	100.0
pod	20	20	100.0
total	171	178	96.0

package Devel::CallerStack;
use strict;
use warnings;

use Devel::CallerStack::Level;
use base 'Exporter';
use Carp;

our $VERSION = '0.003';
our @EXPORT_OK = qw/ caller_stack /;

sub caller_stack { __PACKAGE__->new( 4 )}

sub new {
    my $class = shift;
    my ( $depth ) = @_;
    my $self = bless( [[], undef, 0], $class );
    $self->_build($depth || 3);
    return $self;
}

sub _build {
    my $self = shift;
    my ($depth) = @_;
    while ( my $level = Devel::CallerStack::Level->new( $depth++ )) {
        next if $level->package->isa( __PACKAGE__ );
        push @{ $self->all } => $level;
    }
    return $self;
}

sub _index { \shift->[2] }
sub index { ${ shift->_index }}

sub all { shift->[0] }
sub all_list { @{ shift->all }}

sub _filtered {
    my $self = shift;
    ($self->[1]) = @_ if @_;
    return $self->[1];
}
sub filtered {
    my $self = shift;
    return $self->_filtered( @_ ) || $self->all;
}
sub filtered_list { @{ shift->filtered }}
sub is_filtered { shift->_filtered ? 1 : 0 }

sub unfilter {
    my $self = shift;
    $self->_filtered( undef );
    return $self;
}

sub element {
    my $self = shift;
    my ( $i ) = @_;
    return $self->filtered->[$i];
}

sub recent_package_caller {
    my $self = shift;
    my ( $package ) = @_;
    croak "You must specify a package name" unless $package;
    for my $level ( @{ $self->filtered }) {
        return $level if $level->package( $package );
    }
    return undef;
}

sub distant_package_caller {
    my $self = shift;
    my ( $package ) = @_;
    croak "You must specify a package name" unless $package;
    for my $level ( reverse @{ $self->filtered }) {
        return $level if $level->package( $package );
    }
    return undef;
}

sub package_callers {
    my $self = shift;
    my ( $package ) = @_;
    croak "You must specify a package name" unless $package;

    my @out;
    for my $level ( @{ $self->filtered }) {
        push @out => $level if $level->package( $package );
    }

    return @out;
}

sub filter {
    my $self = shift;
    $self->reset;
    my ( $attr, $check ) = @_;
    my @list =  grep { $_->$attr( $check )} @{ $self->filtered };

    my $want = wantarray;

    return @list if $want;

    $self->filtered( \@list );

    return $self;
}

sub attribute_stack {
    my $self = shift;
    my ( $attribute ) = @_;
    return [ map { $_->$attribute } @{ $self->filtered }];
}

sub recent {
    my $self = shift;
    return $self->filtered->[0];
}

sub distant {
    my $self = shift;
    return $self->filtered->[-1];
}

sub next {
    my $self = shift;
    my $idx = $self->_index;
    return if $$idx >= @{ $self->filtered };
    return $self->filtered->[$$idx++];
}

sub previous {
    my $self = shift;
    my $idx = $self->_index;
    return if $$idx < 1;
    return $self->filtered->[--$$idx];
}

sub reset {
    my $self = shift;
    ${ $self->_index } = 0;
}

1;

__END__