File Coverage

blib/lib/true.pm

Criterion	Covered	Total	%
statement	42	43	97.6
branch	10	14	71.4
condition	5	6	83.3
subroutine	11	11	100.0
pod	0	1	0.0
total	68	75	90.6

package true;

use strict;
use warnings;

use B::Hooks::OP::Annotation;
use B::Hooks::OP::Check;
use Devel::StackTrace;
use XSLoader;

# XXX this declaration must be on a single line
# https://metacpan.org/pod/version#How-to-declare()-a-dotted-decimal-version
use version 0.77; our $VERSION = version->declare('v1.0.1');

our %TRUE;

# set the logger from the first rule which matches the $TRUE_PM_DEBUG
# environment variable:
#
#  - warn with a backtrace (cluck) if it's an integer > 1
#  - warn (without a backtrace) if it's truthy
#  - otherwise (default), do nothing
#
our $DEBUG = do {
    my $debug = $ENV{TRUE_PM_DEBUG} || '0';
    $debug = $debug =~ /^\d+$/ ? int($debug) : 1;
    $debug && ($debug > 1 ? do { require Carp; \&Carp::cluck } : sub { warn(@_) });
};

XSLoader::load(__PACKAGE__, $VERSION);

sub _debug($) {
    $DEBUG->(@_, $/) if ($DEBUG);
}

# return the full path of the file that's currently being compiled.
# XXX CopFILE(&PL_compiling) gives the wrong result here (it works in the
# OP-checker in the XS).
sub ccfile() {
    my ($file, $source, $line);
    my $trace = Devel::StackTrace->new;

    # find the innermost require frame
    #
    # for "use Foo::Bar" or "require Foo::Bar", the evaltext contains
    # "Foo/Bar.pm", and the filename/line refer to the file where the
    # use/require statement appeared.

    # work from the innermost frame out
    while (my $frame = $trace->next_frame) {
        next unless ($frame->is_require);

        my $required = $frame->evaltext;

        if (defined($file = $INC{$required})) {
            $source = $frame->filename;
            $line = $frame->line;
        } else { # shouldn't happen
            warn "true: can't find required file ($required) in \%INC";
        }

        last;
    }

    return wantarray ? ($file, $source, $line) : $file;
}

sub import {
    my ($file, $source, $line) = ccfile();

    if (defined($file) && not($TRUE{$file})) {
        $TRUE{$file} = 1;
        _debug "true: enabling true for $file at $source line $line";
        xs_enter();
    }
}

sub unimport {
    my ($file, $source, $line) = ccfile();

    if (defined($file) && $TRUE{$file}) {
        _debug "true: disabling true for $file at $source line $line";
        delete $TRUE{$file};
        xs_leave() unless (%TRUE);
    }
}

1;

__END__