File Coverage

blib/lib/Devel/CompileLevel.pm

Criterion	Covered	Total	%
statement	33	33	100.0
branch	8	10	80.0
condition			n/a
subroutine	9	9	100.0
pod	2	2	100.0
total	52	54	96.3

package Devel::CompileLevel;
use strict;
use warnings;
no warnings 'once';

our $VERSION = '0.001004';
$VERSION =~ tr/_//d;

use Exporter (); BEGIN { *import = \&Exporter::import }
BEGIN {
  *_WARNING_BITS_CHECK = "$]" <= 5.030001 ? sub(){1} : sub(){0};
}

our @EXPORT_OK = qw(
  compile_level
  compile_caller
);

sub compile_level () {
  no warnings;
  if (_WARNING_BITS_CHECK) {
    local ${^WARNING_BITS} = $warnings::NONE;
    my $level = 0;
    while (my @caller = caller(++$level)) {
      my $hints = $caller[9];
      next
        if $hints ne ${^WARNING_BITS};
      ${^WARNING_BITS} ^= "\x01";
      my $newhints = (caller($level))[9];
      if ($newhints ne $hints) {
        return $level - 1;
      }
    }
  }
  else {
    my $level = 0;
    while (my @caller = caller(++$level)) {
      return $level - 1
        if $caller[3] =~ /::BEGIN\z/;
    }
  }
  return undef;
}

sub compile_caller () {
  my $level = compile_level;
  return
    unless defined $level;

  if (caller eq 'DB') {
    package
      DB;
    caller($level - 1);
  }
  else {
    caller($level - 1);
  }
}

1;

__END__