File Coverage

blib/lib/self.pm

Criterion	Covered	Total	%
statement	51	56	91.0
branch	11	16	68.7
condition	3	3	100.0
subroutine	12	12	100.0
pod	2	2	100.0
total	79	89	88.7

use strict;
use warnings;

package self;
use 5.006;

our $VERSION = '0.34';
use Sub::Exporter;

use Devel::Declare ();
use B::Hooks::Parser;

my $NO_SELF;

sub import {
    my ($class) = @_;
    my $caller = caller;

    B::Hooks::Parser::setup();

    my $linestr = B::Hooks::Parser::get_linestr();
    my $offset  = B::Hooks::Parser::get_linestr_offset();
    substr($linestr, $offset, 0) = 'use B::OPCheck const => check => \&self::_check;';
    B::Hooks::Parser::set_linestr($linestr);

    my $exporter = Sub::Exporter::build_exporter({
        into_level => 1,
        exports => [qw(self args)],
        groups  => { default =>  [ -all ] }
    });
    $exporter->(@_);
}

sub unimport {
    my ($class) = @_;
    my $caller = caller;
    $NO_SELF = 1;
}

sub _check {
    my $op = shift;
    my $caller = caller;
    return if $NO_SELF;
    return unless ref($op->gv) eq 'B::PV';

    my $linestr = B::Hooks::Parser::get_linestr;
    my $offset  = B::Hooks::Parser::get_linestr_offset;

    my $code = 'my($self,@args)=@_;';
    if (substr($linestr, $offset, 3) eq 'sub') {
        my $line = substr($linestr, $offset);
         if ($line =~ m/^sub\s.*{ /x ) {
            if (index($line, "{$code") < 0) {
                substr($linestr, $offset + index($line, '{') + 1, 0) = $code;
                B::Hooks::Parser::set_linestr($linestr);
            }
        }
    }

    # This elsif block handles:
    # sub foo
    # {
    # ...
    # }
    elsif (index($linestr, 'sub') >= 0) {
        $offset += Devel::Declare::toke_skipspace($offset);
        if ($linestr =~ /(sub.*?\n\s*{)/) {
            my $pos = index($linestr, $1);
            if ($pos + length($1) - 1 == $offset) {
                substr($linestr, $offset + 1, 0) = $code;
                B::Hooks::Parser::set_linestr($linestr);
            }
        }
    }

}

sub _args {
    my $level = 2;
    my @c = ();
    package DB;
    @c = caller($level++)
        while !defined($c[3]) || $c[3] eq '(eval)';
    return @DB::args;
}

sub self {
    (_args)[0];
}

sub args {
    my @a = _args;
    return @a[1..$#a];
}

1;

__END__