view release on metacpan or  search on metacpan

lib/Devel/Chitin/Location.pm  view on Meta::CPAN

package Devel::Chitin::Location;

use strict;
use warnings;

our $VERSION = '0.22';

use Carp;
use Scalar::Util qw(weaken reftype);

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");
        }
    }

    if (exists $props{subref}
        and
        ( !ref($props{subref}) or reftype($props{subref}) ne 'CODE' )
    ) {
        Carp::croak("'subref' attribute must be a coderef, not $props{subref}");
    }

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

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

sub _optional_properties {
    qw( callsite subref );
}

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);

            my $subref = Devel::Chitin->current_sub;
            if (ref $subref) {
                $props{subref} = $subref;
            }

            last;
        }
    }
    return $class->new(%props);
}