File Coverage

blib/lib/Devel/Chitin/Location.pm

Criterion	Covered	Total	%
statement	48	62	77.4
branch	5	12	41.6
condition	0	3	0.0
subroutine	12	14	85.7
pod	1	3	33.3
total	66	94	70.2

package Devel::Chitin::Location;

use strict;
use warnings;

our $VERSION = '0.16';

use Carp;

sub new {
    my $class = shift;
    my %props = @_;

    my @props = $class->_required_properties;
    foreach my $prop ( @props ) {
        unless (exists $props{$prop}) {
            Carp::croak("$prop is a required property");
        }
    }

    my $self = bless \%props, $class;
    return $self;
}

sub _required_properties {
    qw( package filename line subroutine );
}

sub _optional_properties {
    qw( callsite );
}

sub at_end {
    my $self = shift;
    return (($self->package eq 'Devel::Chitin::exiting')
            &&
            ($self->subroutine eq 'Devel::Chitin::exiting::at_exit'));
}

sub current {
    my $class = shift;
    my %props = @_;

    for (my $i = 0; ; $i++) {
        my @caller = caller($i);
        last unless @caller;
        if ($caller[3] eq 'DB::DB') {
            @props{'package','filename','line'} = @caller[0,1,2];
            $props{subroutine} = (caller($i+1))[3];
            $props{callsite} = get_callsite($i);
            last;
        }
    }
    return $class->new(%props);
}

sub _make_accessors {
    my $package = shift;
    my @accessor_names;
    @accessor_names = ( $package->_required_properties, $package->_optional_properties );
    if ($package ne __PACKAGE__) {
        # called as a class method by a subclass
        my %base_class_accessors = map { $_ => 1 } (_required_properties(), _optional_properties());
        @accessor_names = grep { ! $base_class_accessors{$_} } @accessor_names;
    }

    foreach my $acc ( @accessor_names ) {
        my $sub = sub { return shift->{$acc} };
        my $subname = "${package}::${acc}";
        no strict 'refs';
        *{$subname} = $sub;
    }
}

sub get_callsite { undef }

BEGIN {
    __PACKAGE__->_make_accessors();

    local $@;
    my $site = eval { require Devel::Callsite && Devel::Callsite::callsite() };
    if ($site) {
        my $get_callsite_name = join('::', __PACKAGE__, 'get_callsite');
        no strict 'refs';
        no warnings 'redefine';
        *$get_callsite_name = \&Devel::Callsite::callsite;
    }
}

1;

__END__