File Coverage

blib/lib/Sub/Called.pm

Criterion	Covered	Total	%
statement	49	55	89.0
branch	13	18	72.2
condition	10	11	90.9
subroutine	7	7	100.0
pod	3	3	100.0
total	82	94	87.2

package Sub::Called;

# ABSTRACT: get information about how the subroutine is called

use warnings;
use strict;

use B;
use Exporter;

our @ISA = qw(Exporter);
our @EXPORT_OK = qw(with_ampersand already_called not_called);

our $VERSION = '0.04';


sub with_ampersand {

    my $sub  = (caller(2))[3] || "main";
    my $line = (caller(1))[2];

    my $func = (caller(1))[3];

    my $svref = \&{$sub};
    my $obj   = B::svref_2object( $svref );

    my $op      = $sub eq 'main' ? B::main_start() : $obj->START;
    my $is_line = 0;
    my $retval  = 0;
    my $is_gv   = 0;

    my $test = B::main_cv;

    for(; $$op; $op = $op->next ){
        my $name    = $op->name;
        if( $name eq 'nextstate' ){
            $is_line = ( $op->line == $line );
        }
        elsif( $name eq 'gv' ){
           my $stash    = "";
           my $globname = "";

           if( B::class( $op ) eq 'PADOP' ){
               my $sv = (( $test->PADLIST->ARRAY)[1]->ARRAY)[ $op->padix ];
               if( $sv ){
                   my $class = B::class( $sv );
                   if( $class eq 'GV' ){
                       $stash    = $sv->STASH->NAME;
                       $globname = $sv->SAFENAME;
                   }
               }
           }
           else {
              $globname = $op->gv->NAME;
              $stash    = $op->gv->STASH->NAME;
           }

           my $check = $stash . '::' . $globname;
           $is_gv    = 1 if $check eq $func;
        }

        next unless $is_line and $is_gv and $name eq 'entersub';

        my $priv = $op->private;

        my $key = 8;
        if( ( $key & $priv) == $key and $priv > $key ){
            $retval = 1;
        }
        last;
    }

    return $retval;
}


my %called;

sub already_called() {
    my ( $package, $filename, $line, $subroutine ) = caller(1);
    my $called = $called{$package}{$subroutine};
    $called{$package}{$subroutine} = 1;
    return $called;
}


sub not_called() {
    my ( $package, $filename, $line, $subroutine ) = caller(1);
    my $called = $called{$package}{$subroutine};
    $called{$package}{$subroutine} = 1;
    return not $called;
}


1; # End of Sub::Called

__END__