File Coverage

blib/lib/Sub/Identify.pm

Criterion	Covered	Total	%
statement	44	45	97.7
branch	17	26	65.3
condition	6	12	50.0
subroutine	9	9	100.0
pod	0	3	0.0
total	76	95	80.0

package Sub::Identify;

use strict;
use Exporter;

BEGIN {
    our $VERSION = '0.12';
    our @ISA = ('Exporter');
    our %EXPORT_TAGS = (
        all => [
            our @EXPORT_OK = qw(
                sub_name
                stash_name
                sub_fullname
                get_code_info
                get_code_location
                is_sub_constant
            )
        ]
    );

    our $IsPurePerl = 1;
    unless ($ENV{PERL_SUB_IDENTIFY_PP}) {
        if (
            eval {
                require XSLoader;
                XSLoader::load(__PACKAGE__, $VERSION);
                1;
            }
        ) {
            $IsPurePerl = 0;
        }
        else {
            die $@ if $@ && $@ !~ /object version|loadable object/;
        }
    }

    if ($IsPurePerl) {
        require B;
        *get_code_info = sub ($) {
            my ($coderef) = @_;
            ref $coderef or return;
            my $cv = B::svref_2object($coderef);
            $cv->isa('B::CV') or return;
            # bail out if GV is undefined
            $cv->GV->isa('B::SPECIAL') and return;

            return ($cv->GV->STASH->NAME, $cv->GV->NAME);
        };
        *get_code_location = sub ($) {
            my ($coderef) = @_;
            ref $coderef or return;
            my $cv = B::svref_2object($coderef);
            $cv->isa('B::CV') && $cv->START->isa('B::COP')
                or return;

            return ($cv->START->file, $cv->START->line);
        };
    }
    if ($IsPurePerl || $] < 5.016) {
        require B;
        *is_sub_constant = sub ($) {
            my ($coderef) = @_;
            ref $coderef or return 0;
            my $cv = B::svref_2object($coderef);
            $cv->isa('B::CV') or return 0;
            my $p = prototype $coderef;
            defined $p && $p eq "" or return 0;
            return ($cv->CvFLAGS & B::CVf_CONST()) == B::CVf_CONST();
        };
    }
}

sub stash_name   ($) { (get_code_info($_[0]))[0] }
sub sub_name     ($) { (get_code_info($_[0]))[1] }
sub sub_fullname ($) { join '::', get_code_info($_[0]) }

1;

__END__