File Coverage

blib/lib/Safe/Caller.pm

Criterion	Covered	Total	%
statement	52	52	100.0
branch	12	20	60.0
condition	4	10	40.0
subroutine	12	12	100.0
pod	5	5	100.0
total	85	99	85.8

package Safe::Caller;

use strict;
use warnings;
use boolean qw(true false);

use Carp qw(croak);

our $VERSION = '0.08_03';

use constant FRAMES => 1;

sub new
{
    my $class = shift;
    my ($frames) = @_;
    $frames ||= FRAMES;

    my $caller = sub
    {
        my ($f, $elem) = @_;
        my $frames = defined $f ? $f : $frames;
        return (caller($frames + 2))[$elem] || '';
    };

    # All fields required because we need
    # to retain backwards compatibility.
    my @sets = (
        [qw(package pkg)],
        [qw(filename file)],
        'line',
        [qw(subroutine sub)],
        'hasargs',
        'wantarray',
        'evaltext',
        'is_require',
        'hints',
        'bitmask'
    );

    my %fields;
    my $i = 0;
    foreach my $set (@sets) {
        foreach my $name (ref $set eq 'ARRAY' ? @$set : $set) {
            $fields{$name} = $i;
        }
        $i++;
    }

    my $accessors = {};
    foreach my $name (keys %fields) {
        $accessors->{$name} = sub
        {
            my $frames = shift;
            return $caller->($frames, $fields{$name});
        };
    }
    $accessors->{_frames} = $frames;

    return bless $accessors, ref($class) || $class;
}

sub called_from_package
{
    my $self = shift;
    my ($called_from_package) = @_;
    croak q(Usage: $caller->called_from_package('Package');)
      unless defined $called_from_package;

    return $self->{package}->() eq $called_from_package
      ? true : false;
}

sub called_from_filename
{
    my $self = shift;
    my ($called_from_filename) = @_;
    croak q(Usage: $caller->called_from_filename('file');)
      unless defined $called_from_filename;

    return $self->{filename}->() eq $called_from_filename
      ? true : false;
}

sub called_from_line
{
    my $self = shift;
    my ($called_from_line) = @_;
    croak q(Usage: $caller->called_from_line(42);)
      unless defined $called_from_line && $called_from_line =~ /^\d+$/;

    return $self->{line}->() == $called_from_line
      ? true : false;
}

sub called_from_subroutine
{
    my $self = shift;
    my ($called_from_subroutine) = @_;
    croak q(Usage: $caller->called_from_subroutine('Package::sub');)
      unless defined $called_from_subroutine;

    return $self->{subroutine}->($self->{_frames} + 1) eq $called_from_subroutine
      ? true : false;
}

# backwards compatibility (deprecated)
*called_from_pkg  = \&called_from_package;
*called_from_file = \&called_from_filename;
*called_from_sub  = \&called_from_subroutine;

1;
__END__