File Coverage

blib/lib/Devel/Trace/Subs.pm

Criterion	Covered	Total	%
statement	73	101	72.2
branch	26	34	76.4
condition	21	30	70.0
subroutine	14	19	73.6
pod	4	4	100.0
total	138	188	73.4

package Devel::Trace::Subs;
use 5.008;
use strict;
use warnings;

use Data::Dumper;
use Devel::Trace::Subs::HTML qw(html);
use Devel::Trace::Subs::Text qw(text);
use Exporter;
use Storable;
use Symbol qw(delete_package);

our $VERSION = '0.24';

our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
    trace
    trace_dump
    install_trace
    remove_trace
);

$SIG{INT} = sub { 'this ensures END runs if ^C is pressed'; };

sub trace {

    return unless $ENV{DTS_ENABLE};

    my $flush_flow = $ENV{DTS_FLUSH_FLOW};

    _env();

    my $data = _store();

    my $flow_count = ++$ENV{DTS_FLOW_COUNT};

    my $flow = {
        name => $flow_count,
        value => (caller(1))[3] || 'main()'
    };

    push @{$data->{flow}}, $flow;

    push @{$data->{stack}}, {
        in       => (caller(1))[3] || '-',
        package  => (caller(1))[0] || '-',
        sub      => (caller(2))[3] || '-',
        filename => (caller(1))[1] || '-',
        line     => (caller(1))[2] || '-',
    };

    _store($data);

    if ($flush_flow){
        print "\n** $flow->{name} :: $flow->{value} **\n";
    }

    if (defined wantarray){
        return $data;
    }
}
sub trace_dump {

    if (! $ENV{DTS_PID}){
        die "\nCan't call trace_dump() without calling trace()\n\n" .
            'Make sure to set $ENV{DTS_ENABLE} = 1;' . "\n\n";
    }

    my %p = @_;

    my $want = $p{want};
    my $out_type = $p{type};
    my $file = $p{file};

    my $data = _store();

    if ($want && $want eq 'stack'){
        if ($out_type && $out_type eq 'html') {
            html(
                file => $file,
                want => $want,
                data => $data->{stack}
            );
        }
        else {
            text(
                want => 'stack',
                data => $data->{stack},
                file => $file
            );
        }
    }
    if ($want && $want eq 'flow'){
        if ($out_type && $out_type eq 'html') {
            html(
                file => $file,
                want => $want,
                data => $data->{flow}
            );
        }
        else {
            text(
                want => 'flow',
                data => $data->{flow},
                file => $file
            );
        }
    }
    if (! $want){
        if ($out_type && $out_type eq 'html') {
            html(
                file => $file,
                data => $data
            );
        }
        else {
            text(
                data => {
                    flow => $data->{flow},
                    stack => $data->{stack}
                },
                file => $file
            );
        }
    }
}
sub install_trace {

    eval {
        require Devel::Examine::Subs;
        Devel::Examine::Subs->import();
    };

    $@ = 1 if $ENV{EVAL_TEST}; # for test coverage

    if ($@){
        die "Devel::Examine::Subs isn't installed. Can't run install_trace(): $@";
    }

    my %p = @_;

    my $file        = $p{file};
    my $extensions  = $p{extensions};
    my $inject      = $p{inject};

    my $des_use = Devel::Examine::Subs->new(file => $file,);

    remove_trace(file => $file);

    # this is a DES pre_proc

    $des_use->inject(inject_use => _inject_use());

    my $des = Devel::Examine::Subs->new(
        file        => $file,
        extensions  => $extensions,
    );

    $inject = $p{inject} || _inject_code();

    $des->inject(
        inject_after_sub_def => $inject,
    );

}
sub remove_trace {

    eval {
        require Devel::Examine::Subs;
        Devel::Examine::Subs->import();
    };

    $@ = 1 if $ENV{EVAL_TEST}; # for test coverage

    if ($@){
        die "Devel::Examine::Subs isn't installed. Can't run remove_trace(): $@";
    }

    my %p       = @_;
    my $file    = $p{file};

    my $des = Devel::Examine::Subs->new( file => $file );

    $des->remove(delete => [qr/injected by Devel::Trace::Subs/]);
}
sub _inject_code {
    return [
        'trace() if $ENV{DTS_ENABLE}; # injected by Devel::Trace::Subs',
    ];
}
sub _inject_use {
    return [
        'use Devel::Trace::Subs qw(trace trace_dump); ' .
        '# injected by Devel::Trace::Subs',
    ];
}
sub _env {

    my $pid = $$;
    $ENV{DTS_PID} = $pid;

    return $pid;
}
sub _store {

    my ($data) = @_;

    my $store = "DTS_" . join('_', ($$ x 3)) . ".dat";

    $ENV{DTS_STORE} = $store;

    my $struct;

    if (-f $store){
        $struct = retrieve($store);
    }
    else {
        $struct = {};
    }

    return $struct if ! $data;

    store($data, $store);

}
sub _fold_placeholder {};

END {
    unlink $ENV{DTS_STORE} if $ENV{DTS_STORE};
}

__END__